/// 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) 2016 Arnaud Bouchez

      Synopse Informatique - http://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) 2016

  the Initial Developer. All Rights Reserved.



  Contributor(s):

   - Aleksandr (sha)

   - Alfred Glaenzer (alf)

   - BigStar

   - itSDS

   - Johan Bontes

   - kevinday

   - mazinsw

   - Marius Maximus (mariuszekpl)

   - RalfS

   - Sanyin

   - Pavel (mpv)

   - Wloochacz

   - zed



  Alternatively, the contents of this file may be used under the terms of

  either the GNU General Public License Version 2 or later (the "GPL"), or

  the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),

  in which case the provisions of the GPL or the LGPL are applicable instead

  of those above. If you wish to allow use of your version of this file only

  under the terms of either the GPL or the LGPL, and not to allow others to

  use your version of this file under the terms of the MPL, indicate your

  decision by deleting the provisions above and replace them with the notice

  and other provisions required by the GPL or the LGPL. If you do not delete

  the provisions above, a recipient may use your version of this file under

  the terms of any one of the MPL, the GPL or the LGPL.



  ***** END LICENSE BLOCK *****



  Version 1.7

  - first public release, corresponding to SQLite3 Framework 1.7



  Version 1.8

  - includes Unitary Testing class and functions

  - bug fixed in WinAnsiBufferToUtf8() and all WinAnsi to UTF-8 encoding

    functions (issue identified thanks to new _UTF8 testing function)

  - bug fixed in val() under Delphi 2009/2010 for some values (issue identified

    thanks to new NumericalConversion testing function)

  - bug fixed in AnsiICompW() - used in SynPdf unit

  - ambiguous SameText() function rewritten as SameTextU() with UTF-8 decoding

  - TTextWriter class moved from SQLite3Commons to SynCommons

  - new JSONEncode and JSONDecode functions to directly encode or decode any

    content to/from a valid UTF-8 JSON object content

  - enhanced URLEncode() and URLDecode() functions

  - new ExtendedToStr/ExtendedToString functions

  - new tests added (mostly relative to the new functions or classes)



  Version 1.9

  - now compiles under CrossKylix, and tested under Linux

  - new JSONEncodeArray procedures, to create JSON array content from

    supplied Delphi arrays (handle RawUTF8 text, double or integer arrays)

  - new AddCSV methods in TTextWriter handling Delphi arrays to be added

    as Comma-Separated-Values (handle RawUTF8 text, double or integer arrays)

  - new definition of PtrInt/PtrUInt, to match NativeInt/NativeUInt types,

    available since Delphi 2007 - some code rewrite in order to avoid any

    implicit conversion from/to integer/cardinal



  Version 1.9.2

  - new StringReplaceChars function



  Version 1.10

  - code modifications to compile with Delphi 6 compiler (Delphi 5 failed due

    to some obscure compiler bugs in SynCrypto.pas)



  Version 1.11

  - fix some obscure Delphi 2009 bug according to NativeUInt :(

  - source code modified to be 7 bit Ansi (so will work with all encodings)

  - a lot of code refactoring for our internal fork of ZeosLib

    (e.g. ISO 8601 date time extracted from SQLite3Commons, QuotedStr..)

  - new TRawUTF8List class, which is able to emulate a TStringList with our

    native UTF-8 string type (cross-compiler, from Delphi 6 up to XE)

  - new TRawUTF8Stream class, to typecast a RawUTF8 into a TStream

  - new IsWow64 and SystemInfo global variables



  Version 1.12

  - fixed issue "JSON floats decimal separator depends on language settings"

  - new UTF8ToWideChar() overloaded function, with MaxDestChars parameter

  - new FillIncreasing() procedure

  - now handle our 32/64-bit variable-length integer encoding, via new

    FromVarUInt32/64 and ToVarUInt32/64 functions

  - new TFileBufferReader and TFileBufferWriter objects, implementing very fast

    read/write access to huge files, with new 32/64-bit variable-length integer

    encoding and optimized storage of IDs or Offsets (used in TSynBigTable)

  - new function UnQuoteSQLString()

  - another review of Pos() calls in the code (now use our fast PosEx)

  - TSynMemoryStream now replaces TRawUTF8Stream class, with constructors using

    either an AnsiString, either a memory buffer

  - new TSynTable, TSynTableFieldProperties and TSynTableStatement classes

    to handle a generic database table storing field values using our SBF

    compact binary format (more compact than BSON, similar to Protocol Buffers)

  - new WinAnsiToUnicodeString and Ansi7ToString functions

  - new TTextWriter.AddBinToHex method

  - new CompareOperator() functions and associated TCompareOperator type

  - new IntToThousandString() function (used for TSynTests e.g.)

  - new CreateInternalWindow() for creating a Windows Message handler in any object



  Version 1.13

  - unit now compiles and works with Delphi 5 compiler

  - new low-level RTTI functions for handling record types: RecordEquals,

    RecordSave, RecordSaveLength, RecordLoad, RecordClear and RecordCopy

  - new TDynArray object, which is a wrapper around any dynamic array: you can

    now access to the dynamic array using TList-like properties and methods,

    e.g. Count, Add, Insert, Delete, Clear, IndexOf, Find, Sort and some

    new methods like LoadFromStream, SaveToStream, LoadFrom and SaveTo which

    allow fast binary serialization of any dynamic array, even containing

    strings or records; a CreateOrderedIndex method is also available to

    create individual index according to the dynamic array content; and any

    dynamic array can be serialized as UTF-8 JSON via TTextWriter.AddDynArrayJSON

    and TDynArray.LoadFromJSON methods

  - introducing direct content filtering and validation using

    TSynFilterOrValidate dedicated classes, for both TSQLRecord and SynBigTable

  - filtering is handled via some TSynFilter classes - TSynFilterUpperCase,

    TSynFilterUpperCaseU, TSynFilterLowerCase, TSynFilterLowerCaseU and

    TSynFilterTrim e.g.

  - validation is handled via some TSynValidate classes - TSynValidateRest,

    TSynValidateIPAddress, TSynValidateEmail, TSynValidatePattern,

    TSynValidatePatternI, TSynValidateText, TSynValidatePassWord e.g.

  - dedicated TSynTableFieldProperties.Validate method for validation (e.g. a

    TSynValidateTableUniqueField instance is created if tfoUnique is in Options)

  - dedicated TSynTableFieldProperties.Filter method for filtering (using

    common TSynFilter classes, working at UTF-8 Text content)

  - faster implementation of Move() for Delphi versions with no FastCode inside

  - new ConvertCaseUTF8(), UpperCaseU(), LowerCaseU(), Int64ToUInt32(),

    GetCardinalDef(), IsValidEmail, IsValidIP4Address(), PatchCodePtrUInt(),

    GetCaptionFromClass(), GetDisplayNameFromClass(), DateTimeToIso8601Text()

    StrUInt32(), StringBufferToUtf8(), IsZero(), AddPrefixToCSV(), IntToString(),

    RawUTF8DynArrayEquals(), FromVarString(), GetBitCSV(), SetBitCSV()

    procedures or functions (with associated tests)

  - new grep-like IsMatch() function for basic pattern matching

  - new BinToBase64, Base64ToBin and IsBase64 *fast* conversion functions

    (with optimized assembler version, using CPU pipelining and lookup table)

  - introducing the GarbageCollector TObjectList for handling a global garbage

    collector for instances which must live during the whole executable process

    (used e.g. to avoid a memory leak for "class var" or such variables)

  - new TSynLog class to handle enhanced logging to any application, with

    exception handling (+stack trace) and customer-side performance profiling

  - new TSynMapFile class to retrieve debugging information from .map file (and

    able to save and read smaller .mab files) - used by TSynLog if available

  - new TSynTestsLogged test suit class, with automated test case logging

  - Windows version detection enhanced, now retrieving TWindowsVersion enumerate

  - great performance improvement in TSynTableFieldProperties for update process

  - added TMemoryMap and TSynMemoryStreamMapped to handle memory-mapped files

  - added TMemoryMapText class to fast handle big UTF-8 text files (like logs)

  - now TTextWriter can have a custom internal buffer size (default 4096 bytes)

  - now TFileBufferWriter and TFileVersion are regular classes, not an

    object/record any more (this was incoherent since Delphi 2010)

  - new TFileBufferReader.OpenFrom(Stream) and ReadRawUTF8 methods

  - now TSynCache will use faster TDynArrayHashed for its content hashing

  - new Escape: TTextWriterKind optional parameter for TTextWriter.Add()

  - new SynLZ related compression functions: FileSynLZ/FileUnSynLZ and

    StreamSynLZ/StreamUnSynLZ

  - source can now be parsed per all Delphi IDE pre-parser (dual declaration as

    record or object because of Delphi 2010 and up was not understood)

  - fixed issue in TSynTable.Data() method: ID was not set as expected

  - fixed issue in TSynTableFieldProperties: wrong constraint evaluation and

    index refresh at records update

  - fixed issue in ToVarUInt32Length/ToVarUInt32LengthWithData



  Version 1.14

  - fix issues with Curr64ToStr() and Curr64ToPChar() with negative amounts,

    with some speed enhancements and new associated tests

  - fixed issue in produced JSON stream using '=' instead of ':'

  - new DoubleToStr(), StrCurr64(), UnicodeBufferToString(),

    RawUnicodeToString(), FillChar(), UpperCopy255W(), GetCaptionFromEnum(),

    SortDynArrayUnicodeString(), SortDynArrayUnicodeStringI() functions



  Version 1.15

  - unit now tested with Delphi XE2 (32 Bit)

  - TSynLog now writes the elapsed time (in us) for Enter/Leave events, and

    will flush the log content to disk on any exception (for safety)

  - new sllTrace and sllWarning levels for TSynLog class

  - new TSynLog.DefaultExtension property (set to '.log' by default)

  - new TSynLogFile.LogProc[] property for customer-side method profiling,

    with LogProcSort method available for sorting the resulting array, and

    LogProcMerged property to merge the location name timing

  - new TSynMapFile.FindLocation method for high-level .map symbol access

  - TSynMapFile now handles huge .map file (bigger default in-memory buffer)

  - fix potential GPF issue in code using ConvertHexToBin[]

  - new TSynLog.EventCount method

  - new TMemoryMapText.LineContains method for fast case-insensitive search

  - TSynTests now writes the elapsed time in each test in the final report

  - faster late binding process for our variants custom types (i.e.

    TSynTableVariantType and TSQLDBRowVariantType): you can call

    SynRegisterCustomVariantType() function to register any other custom

    variant type, and enhance GetProperty/SetProperty process speed

  - includes our optimized RecordCopy procedure in replacement to the slower

    default System.@CopyRecord internal RTL function

  - our optimized Move() and FillChar() will replace the default System RTL

    function, for Delphi versions prior to 2007 (which didn't contain those)

  - new AnsiCharToUTF8(), StringToWinAnsi(), WideStringToWinAnsi(),

    WideStringToUTF8(), CSVOfValue(), IdemPCharArray(), FindUnicode(),

    UpperCaseUnicode(), LowerCaseUnicode() and Split() functions

  - faster GetInt64() function

  - Iso8601ToSecondsPUTF8Char() now returns 0 in case of unexpected format

  - fixed issue in StrCurr64() low-level conversion routine

  - fixed issue in Utf8DecodeToRawUnicodeUI() function

  - new TSynTableFieldProperties.OrderedIndexRefresh method, to allow access

    on OrderedIndex[] even if the index needs to be refreshed

  - new TDynArrayHashed.AddAndMakeUniqueName() method and Hash[] property

  - new TRawByteStringStream class (a TStream using a RawByteString as internal

    storage), especially useful since Delphi 2009

  - new TSynNameValue object, to efficiently handle Name/Value RawUTF8 pairs

    (using hashing for Name search)

  - TTextWriter.CreateOwnedStream now create an internal TRawByteStringStream

    instance for faster process and direct retrieval in the Text method

  - JSONEncode*() global functions will use an internal TRawByteStringStream

    instead of a supplied TMemoryStream

  - new FormatUTF8() overloaded function, handling both '%' and '?' parameters

    (inserting '?' as inlined :(...): parameters, with proper string quote) -

    with associated regression tests



  Version 1.16

  - introducing new TSynAnsiConvert and TSynAnsiFixedWidth classes, able to

    process Unicode to/from Ansi conversion in all possible code pages, with

    generic access methods and optimized handling of fixed width encodings

  - added dedicated Exception classes (ESynException, ETableDataException)

  - TSynLog allows read sharing of the .log created file

  - TSynLog now stores the executable build time, and library name (if any) -

    this is a small change of the .log format as expected by the LogViewer tool

    (so you should upgrade your LogViewer.exe to its latest version)

  - TSynLog and TSynMapFile now handle libraries (.dll/.ocx/.bpl) .map/.mab

    debugging information (only .exe was previously handled)

  - TSynCache now handles an optional Tag: PtrInt value parameter (used e.g.

    to store the row counts of a SQL result cache in mORMot)

  - TSynCache now uses the generic TSynNameValue object from its internal

    hashed list implementation (avoid duplicated code)

  - TMemoryMapText class (and therefore TSynLogFile) is now able to map/open

    an existing file: it will allow e.g. the SynLogViewer to browse a .log file

    which is actually still opened and working by the main application

  - faster RawUnicodeToUtf8() and UTF8ToWideChar() functions, thanks to very

    clever speed-up proposals by Sha (also included in TSynAnsi* classes)

  - JSONDecode() overloaded functions now accept parameter names without case

    sensibility (and a new HandleValuesAsObjectOrArray parameter)

  - new JSONDecode() overloaded function, to properly handle unserialization

    of a JSON object within a buffer (used e.g. for TDynArrayJSONCustomReader)

  - JSON functions now handle '0' as number according to http://json.org specs

  - new TTextWriter.AddJSONEscape() overloaded function, to be used to directly

    serialize some name/value pairs as a JSON object content (used e.g. for

    TDynArrayJSONCustomWriter callbacks)

  - new FileSize(), RoundTo2Digits() and RawByteStringArrayConcat() functions

  - new TPrecisionTimer Pause and Resume methods

  - new TSynTestCase.CheckFailed method (most of the time, Check is sufficient)

  - new TSynLogFamily.IncludeComputerNameInFileName property

  - new TTextWriter.WrRecord method for direct adding of a Base-64 record content

  - new TTextWriter.AddNoJSONEscapeString method

  - new TRawUTF8ListHashed class, with extend TRawUTF8List by using an internal

    hash table to optimized IndexOf() method call (including case sensitivity)

  - new ToVarInt64() and FromVarInt64() functions to encode and decode

    variable-length signed Int64 values (with the corresponding new tftVarInt64

    kind of variable-length column in TSynTableFieldType enumeration)

  - new GotoNextJSONObjectOrArray() and RawUTF8ArrayToQuotedCSV() functions

  - new ReadStringFromStream() and WriteStringToStream() functions

  - fixed some compilation warnings with Delphi XE and XE2

  - fixed issue in TDynArrayHashed if you do not use the external Count

  - fixed potential GPF in TDynArrayHashed.ReHash after TDynArray.Clear call

  - fixed issue in TSynTableFieldProperties.SaveTo about saving wrong indexes

  - fixed issue TSynTableStatement when only one column was retrieved

  - fixed rounding issue in ExtendedToString() and all corresponding wrappers

    like DoubleToStr*, Add(Double...)

  - fixed issue in Hash32() implementation (potential GPF when reading ahead

    by DWORD - get rid of unnecessary asm optimization)

  - fixed issues in function IsJSONString() which returned TRUE for '-' or '+',

    or false positives in some border-line cases (due to wrong uppercase guess):

    now this function is split into IsString() and IsStringJSON() functions

    to explicitely handle null/false/true constant recognition

  - fixed potential false positives of null/false/true in function GetJSONField

  - get rid of wrong "Decimal" parameter in float to text conversion

  - TFileBufferWriter.Create now accepts up to 4 MB internal buffer size

  - increased TDynArrayHashed number of void entries (for speed)

  - modified TDynArray.SaveToStream/LoadFromStream to read or save the data

    from the current stream position

  - fixed GPF in TDynArray.SaveTo in case of invalid internal record layout

  - modified StreamUnSynLZ() so that Source stream will point after all read data

  - TDynArray.SaveToStream() method can now save to any TStream class

  - added TTextWriter.RegisterCustomJSONSerializer() method to allow JSON

    serialization of any dynamic array content (used by TDynArray.LoadFromJSON

    and TTextWriter.AddDynArrayJSON) and record content (used by RecordLoadJSON

    and TTextWriter.AddRecordJSON)

  - added USEPACKAGES conditional to help compiling the unit within packages

  - added optional DOPATCHTRTL to patch the RTL (e.g. RecordCopy, RecordClear

    TObject.CleanupInstance low-level functions) only if needed (not patched

    by default, for compatibility reasons) - you may want to use our Enhanced

    RTL patchs instead for a whole better response

  - new function BinToBase64URI()

  - circumvent some bugs of Delphi XE2 background compiler (main compiler is OK)

  - add premilinary Windows 8 operating system detection (as wEight/wEightServer)



  Version 1.17

  - check of QueryPerformanceFrequency failure, and rollback to low-resolution timer

  - handle properly old .synlz layout (reading compatibility was broken)

  - added TObjectListHashed class, which behaves like TList/TObjectList, but

    will use hashing for (much) faster IndexOf() method, and associated

    TObjectListPropertyHashed class, which allows hashing of a sub-property

    of an object (including some changes made to TDynArray/TDynArrayHashed)

  - new TTextWriter.AddDateTime() overloaded method able to quote the output

  - new TTextWriter.AddFloatStr() method handling partial floating-point text

  - both TTextWriter.AddDateTime() overloaded methods will store '' when value

    is 0, or a pure ISO-8601 date or time if the value is defined as such,

    just as expected by http://www.sqlite.org/lang_datefunc.html - it will also

    reduce average generated JSON/text content size

  - fixed issue about BLOB unproperly serialized into JSON (e.g. now uses null)

  - fixed ticket [e5ad3684b2] about some .map files parsing in TSynMapFile

  - TSynLog stack tracing uses low-level RtlCaptureStackBackTrace() API on CPU64

  - changed the non expanded JSON format to use lowercase first column names:

    {"fieldCount":1,"values":["col1"... instead of {"FieldCount":1,"Values":[..

  - new SetInt64() procedure for direct assignment of the result

  - TSynTableStatement class now accepts '_' in table and column identifiers

  - fixed implementation issue in function FindNextUTF8WordBegin()

  - fixed false negative issue in TSynSoundEx.UTF8 and TSynSoundEx.Ansi

  - fixed wrong UTF-8 encoding of U+FFF0 used for JSON_BASE64_MAGIC

  - added an optional parameter to StrToCurr64() function, able to return

    a true Int64 value if no decimal is supplied within the input text buffer

  - enhanced TSynAnsiFixedWidth.UnicodeBufferToAnsi average process speed

  - TSynCache.Reset now returns a boolean stating if something was flushed

  - new SynUnicodeToUtf8(), ShortStringToUTF8(), StringToSynUnicode(),

    SynUnicodeToString() functions

  - new StrToCurrency() wrapper function

  - new IdemPropName() overloaded function with two PUTF8Char arguments

  - new UTF8UpperCopy() and UTF8UpperCopy255() optimized functions

  - new GotoNextNotSpace() and GotoEndOfQuotedString() functions

  - new TMemoryMap.Map() method expecting a file name as parameter

  - new TRawUTF8List.LoadFromFile method

  - new DateToSQL(), DateTimeToSQL() and Iso8601ToSQL() functions, returning

    a string with a JSON_SQLDATE_MAGIC prefix and proper UTF-8/ISO-8601 encoding

    to be inlined as ? bound parameter in any SQL query (allow binding of

    date/time parameters as request by some external database engine

    which does not accept ISO-8601 text in this case)

  - added TDynArray.Equals() method to compare two arrays efficiently

  - added TDynArray and TDynArrayHashed InitSpecific() method able to specify

    how (hashing and) comparison should be processed for a given record

    (includes also some TDynArray/TDynArrayHashed refactoring and optimization)

  - new TObjectHash abstract class to use hashing to find an object

  - TTextWriter.AddJSONEscape() method speed up

  - moved logging threadvars and associated structures into hidden internal

    declaration, for better work with packages (avoid W1032 warning)

  - now JSON parser will handle #1..' ' chars as whitespace (not only ' ')

  - now JSON parser will allow whitespace inserted between any pair of tokens,

    even after true/false/null, as expected by the specification

  - fixed potential Integer Overflow error in Iso8601ToDateTimePUTF8Char*()

  - added PatchCode() and RedirectCodeRestore() procedures, and some code

    refactoring about process in-memory code patching

  - internal FillChar() will now use faster SSE2 instructions on supported CPUs



  Version 1.18

  - BREAKING CHANGE: SynLog.pas and SynTests.pas were extracted from SynCommons

  - BREAKING CHANGE of TTextWriter.WriteObject() method: serialization is now

    defined with a new TTextWriterWriteObjectOptions set

  - BREAKING CHANGE rename of Iso8601 low-level structure as TTimeLogBits, to use

    explicitly the TTimeLog type and name for all Int64 bit-oriented functions -

    now "Iso8601" naming will be only for standard ISO-8601 text, not Int64 value

  - BREAKING CHANGE: TTextWriter.Add(Format) won't handle the alternate $ % tags

    any more, unless you define the OLDTEXTWRITERFORMAT conditional

  - BREAKING CHANGE: TTextWriter.AddDouble() and AddSingle() dedicated methods

    replacing ambiquituous Add(), which was not appropriate for single values

  - BREAKING CHANGE: FormatUTF8() and TTextWriter.Add(Format) PUTF8Char type for

    constant text parameter has been changed into RawUTF8, to let the compiler

    handle any Unicode content as expected

  - RawByteString is now defined as "= type AnsiString" under non Unicode Delphi

    so that it would be recognized with its own encoding (pseudo code page 65535)

  - Delphi XE4/XE5/XE6/XE7/XE8/10/10.1 compatibility (Win32/Win64 target

    platforms only for the SynCommons and mORMot* units, but SynCrossPlatform* 

    supports clients on all other targets, including OSX and NextGen compilers)

  - unit fixed and tested with Delphi XE2 (and up) 64-bit compiler under Windows

  - now all variants created within our units will create string instances of

    kind varString and type RawUTF8 - prior to Delphi 2009, ensure you call

    UTF8ToString(aVariant) if you want to use the value with the VCL

  - introducing TDocVariant for variant-based process of any hierarchy

    of objects and/or arrays, with late binding optimized access and JSON

    serialization/unserialization (will also be used for BSON documents storage)

  - UTF-8 process will now handle UTF-16 surrogates - see ticket [4a0382367d] -

    UnicodeCharToUTF8/NextUTF8Char are renamed WideCharToUTF8/NextUTF8UCS4 and

    new UTF16CharToUTF8/UCS4ToUTF8 functions have been introduced

  - added ToUTF8() overloaded functions, which could be used on most simple types

  - introducing TSynTimeZone class, for cross-platform local time handling 

  - added TextColor() and TextBackground() functions - will initialize internal

    console process after any manual AllocConsole call

  - added ConsoleWaitForEnterKey function, able to handle Synchronize() calls

  - StrLen() function will now use SSE2 or SSE4.2 instructions on supported CPUs

  - introduced StrLenPas() function, to be used when buffer is protected

  - UpperCopy255Buf() function will use SSE4.2 instrctions on supported CPUs

    to speed up e.g. HashAnsiStringI()

  - included Windows-1258 code page to be recognized as a fixed-width charset

  - TSynAnsiFixedWidth.Create(CODEPAGE_US) will now use a hard-coded table,

    since some Russian system do tweak the registry to force 1252 page maps 1251

  - introducing TSynAnsiUTF8/TSynAnsiUTF16 to handle CP_UTF8/CP_UTF16 codepages

  - added UTF8AnsiConvert instance, and let TSynAnsiConvert.Engine(0) return

    the main CurrentAnsiConvert instance

  - StrComp/StrIComp/StrLen() functions will now expect blank pointers, to

    circumvent type mismatchs when passing PAnsiChar or PUTF8Char buffers

  - get rid of 12 maximum count of supplied argument in FormatUTF8()

  - FormatUTF8() and VarRecToUTF8() will append the class name of any TObject

  - added JSONFormat optional parameter to FormatUTF8() to produce valid JSON

    content from a given set of values identified by ? - used e.g. by _JsonFmt()

  - added ESynException.CreateUTF8() constructor, more powerful than the

    default Exception.CreateFmt(): this CreateUTF8 method is now used everywhere

  - added QuotedStrJSON() and NextNotSpaceCharIs() functions

  - refactored GetMimeContentType() implementation - see also [fca72ba0ce] -

    and introduced GetMimeContentTypeHeader() function

  - added MultiPartFormDataDecode() to decode multipart/form-data POST requests

  - included x64 asm of FillChar() and Move() for Win64 - Delphi RTL will be

    patched at startup, if the DOPATCHTRTL conditional is defined

  - introduced FillcharFast() and MoveFast() global function variables,

    pointing to optimized asm versions, depending on the CPU abilities

  - FastCode-based x86 asm Move() procedure will handle source=dest

  - faster x86/x64 asm versions of StrUInt32() StrInt32() StrInt64() functions

  - new StrUInt64(), UniqueRawUTF8(), FastNewRawUTF8() and SetRawUTF8() functions

  - introducing UTF8ToInteger() overloaded functions

  - recognize 8.1 and upcoming "Threshold" 9 in TWindowsVersion

  - added TypeInfo, ElemSize, ElemType read-only properties to TDynArray

  - added DynArrayLoad() and DynArraySave() helper functions

  - introducing TObjectDynArrayWrapper class and IObjectDynArray interface

  - introducing T*ObjArray dynamic array storage via ObjArrayAdd/ObjArrayFind/

    ObjArrayDelete/ObjArraySort and ObjArrayClear functions

  - introducing T*InterfaceArray dynamic array storage via InterfaceArrayAdd/

    InterfaceArrayFind/InterfaceArrayDelete functions

  - added TPersistentWithCustomCreate, TInterfacedObjectWithCustomCreate and

    TSynPersistent abstract classes, allowing to define virtual constructors for

    TPersistent kind of objects (used e.g. with internal JSON serialization,

    for interface-based services, or for DDD objects)

  - introducing TSynPersistentLocked and TInterfacedObjectLocked classes,

    avoiding CPU cache line performance issue (so to be preferred to TMonitor or

    TCriticalSection)

  - new TSynPersistentWithPassword class, able to store the password with

    a custom simple encryption when serialized as JSON

  - introducing TSynAuthentication class for simple generic authentication

  - introducing TSynConnectionDefinition class used e.g. for JSON-defined

    runtime instantiation of a TSQLDBConnectionProperties or TSQLRest instance

  - added TDynArrayHashed.HashElement property

  - new TDynArrayHashed.AddUniqueName() method

  - introduced TSingleDynArray, recognized as such in JSON serialization

  - fixed "single" floating-point values JSON serialization

  - added WordScanIndex() and swap32() functions

  - speed improvement of IdemPropNameU() function, with new overload function

  - now FileSize() function won't raise any exception if the file does not exist

    and will return any size > 2 GB as expected

  - faster PosEx() function in pure pascal mode (based on Avatar Zondertau work)

  - introducing StreamToRawByteString() / RawByteStringToStream() functions

  - introducing RawByteStringToBytes() / BytesToRawByteString() functions

  - added StringDynArrayToRawUTF8DynArray() and StringListToRawUTF8DynArray()

  - added CSVToRawUTF8DynArray() overloaded functions

  - added GetLastCSVItem() function and dedicated HashPointer() function

  - added DirectoryDelete() and EnsureDirectoryExists() function

  - added FileOpenSequentialRead() function, used e.g. by StringFromFile()

  - added GetNextItemInteger(), GetNextItemCardinalStrict() and UpperCaseCopy()

  - added GetEnumNameValue() and UnQuotedSQLSymbolName() functions

  - added JSONEncodeArrayOfConst() function

  - JSONEncode() and TTextWriter.AddJSONEscape() with NameValuePairs parameters

    will now handle nested arrays or objects specified with '['..']' or '{'..'}'

    and nil parameter as null JSON value

  - new TTextWriter.AddJSON() method and JSONEncode() overloaded function able

    to recognize (extended) JSON content, including MongoDB shell extensions

  - added IsHTMLContentTypeTextual() function, and modified ExistsIniNameValue()

  - added ShortStringToAnsi7String() and UpperCopyWin255() functions

  - added IsEqualGUID/IsNullGuid/GUIDToText/GUIDToRawUTF8/GUIDToString functions

  - added AddGUID/RandomGUID/TextToGUID/RawUTF8ToGUID/StringToGUID functions

  - added TDynArray.ElemPtr() low-level method

  - let TDynArray.LoadFrom() accept Win32/Win64 cross platform binary content

  - new TDynArray.CopyFrom() method and associated procedure DynArrayCopy()

  - TDynArray will now recognize variant/interface fields

  - new TDynArray.FastLocateSorted FastAddSorted FastLocateOrAddSorted methods

  - new TPendingTaskList class, for storing e.g. a time-ordered list of tasks

  - code refactoring of TTextWriter to simplify flushing mechanism, and

    allow internal buffer auto-grow if it was found out to be too small (see

    FlushToStream / FlushFinal methods and FlushToStreamNoAutoResize property)

  - fixed ticket [5bd9df5979] about TTextWriter.CancelAll issue

  - added optional internal buffer size for TTextWriter.CreateOwnedStream()

  - added new constructor TTextWriter.CreateOwnedFileStream()

  - added TTextWriter.LastChar and TTextWriter.AddStrings() methods

  - added TTextWriter.ForceContent method

  - added faster TTextWriter.SetText() method in conjuction to Text function

  - added TTextWriter.Add(const guid: TGUID) and Add(Value: boolean) methods

  - TTextWriter.Add(Format..) will now ignore any character afer |, i.e. |$ = $

  - added TTextWriter.AddQuotedStr() and AddStringCopy() methods

  - added TTextWriter.AddVoidRecordJSON() method

  - added TTextWriter.AddJSONEscapeAnsiString() method

  - added TTextWriter.AddAnyAnsiString() method and AnyAnsiToUTF8() function

  - added TTextWriter.EndOfLineCRLF property

  - for Delphi 2010 and up, RecordSaveJSON/RecordLoadJSON will use enhanced RTTI

  - before Delphi 2010, you can specify the record layout as text to

    TTextWriter.RegisterCustomJSONSerializerFromText() for JSON serialization

  - added TTextWriter.RegisterCustomJSONSerializerSetOptions() for [da22968223]

  - added TTextWriter.AddDynArrayJSON() overloaded method and new functions

    DynArrayLoadJSON() and DynArraySaveJSON() to be used e.g. for custom

    record JSON serialization, using TDynArrayJSONCustomReader/Writer

    callbacks and/or RegisterCustomJSONSerializerFromText(), or enhanced RTTI

  - added TTextWriter.AddDynArrayJSONAsString method, and moved

    TTextWriter.WriteObjectAsString from TJSONSerializer

  - added TTextWriter.UnRegisterCustomJSONSerializer() method

  - added TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType() method

  - added TTextWriter.AddTypedJSON() and AddCRAndIdent methods

  - added TTextWriter.SetDefaultJSONClass to force TJSONSerializer use

  - added TJSONWriter.EndJSONObject() method, for writing an optional

    ',"rowCount":' field in non expanded mode - used for all JSON creation

  - added TTextWriter.EchoAdd() and EchoRemove() methods

  - added QuickSortIndexedPUTF8Char() and FastFindIndexedPUTF8Char()

  - added overloaded QuickSortInteger() for synchronous sort of two arrays

  - fixed potential critical issue [99fe8a1eba] in SortDynArrayInt64/Cardinal

  - added GetNextItem64() Int64Scan() Int64ScanExists() QuickSortInt64()

    FastFindInt64Sorted() AddInt64() CSVToInt64DynArray() Int64DynArrayToCSV()

    and VariantToInt64() functions (used during TID=Int64 introduction in ORM)

  - added RawUnicodeToUtf8() and UTF8ToSynUnicode() overloaded procedures

  - added HexToChar/HexToCharValid and UrlDecodeNextName(), UrlDecodeNextValue()

    and UrlDecodeNextNameValue() functions

  - added Utf8DecodeToRawUnicodeUI() overloaded function returning text as var

  - added UrlEncodeJsonObject() and new overloaded JSONDecode() function

  - added TRawUTF8DynArrayFrom(const Values: array of RawUTF8) function

  - added overloaded function FindRawUTF8() using array of RawUTF8 parameter

  - added TPropNameList record/object to maintain a stack-based list of names

  - speeed enhancement for TRawUTF8List.Add()

  - new TRawUTF8List.SaveToStream and SaveToFile methods

  - new TRawUTF8List.PopFirst and PopLast methods

  - added optional aOwnObjects parameter to TRawUTF8List.Create() constructor

  - new TRawUTF8List.GetObjectByName() method

  - refactoring of CaseSensitive property for TRawUTF8List / TRawUTF8ListHashed

  - added TRawUTF8List.CaseSensitive property as requested by [806332d296]

  - added TRawUTF8MethodList class (based on TRawUTF8ListHashed)

  - added TRawUTF8ListHashedLocked class (based on TRawUTF8ListHashed)

  - added TPointerClassHash and TPointerClassHashLocked classes (used e.g.

    to store RTTI cache, for T*ObjArray process)

  - added TAutoLocker/IAutoLocker and TLockedDocVariant/ILockedDocVariant types

  - added TAutoFree class, for automatic local variable lifetime management

  - added JSON_CONTENT_TYPE_HEADER and XML_CONTENT_TYPE[_HEADER] constants

  - new DateToSQL() overloaded function with direct Year/Month/Day parameters

  - added Base64MagicDecode(), Base64MagicCheckAndDecode() and SQLToDateTime()

  - added IsEqual(const A,B: TSQLFieldBits): boolean function

  - enhanced FPC/Lazarus Win32/Win64 compilation

  - TDynArrayHashed is now a record with Delphi 2009+, due to a bug in latest

    version of Delphi compiler when using TDynArrayHashed = object(TDynArray)

  - fixed [7658da5529] unexpected hash collision in TDynArrayHashed

  - fixed unexpected GPF in TSynCache.Find() e.g. when cache is disabled

  - handle variant serialization in/from JSON using new VariantLoadJSON(),

    VariantSaveJSON(), VariantSaveJSONLength() functions and corresponding

    TTextWriter.AddVariant() method

  - handle variant serialization in/from our binary custom format, using new

    VariantLoad(), VariantSaveLength() and VariantSave() functions

  - added VariantToUTF8() overloaded functions for fast conversion

  - added VariantToInteger()/VariantToIntegerDef()/VariantToInt64() functions

    for direct process of numerical variants (e.g. array indexes)

  - new RawUTF8ToVariant() and VarRecToVariant() functions

  - new RawByteStringToVariant() and VariantToRawByteString() functions

  - added VariantDynArrayToJSON/JSONToVariantDynArray/ValuesToVariantDynArray()

  - added VariantDynArrayClear() function (faster e.g. for array of TDocVariant)

  - added VariantToInlineValue() and VarRecToInlineValue() functions

  - added VarRecToInt64(), VarRecToDouble() and VarRecAsChar() functions

  - added overloaded Int32ToUTF8() Int64ToStr() Curr64ToStr() ExtendedToStr()

    PointerToHex() UInt32ToUtf8() procedures

  - handle binary serialization of variant via FromVarVariant() procedure and

    TFileBufferWriter.Write() method

  - added ToVarString(), FromVarInt64Value() and FromVarBlob() functions

  - added TFileBufferWriter.WriteVarInt64 and TFileBufferReader.ReadVarInt64

  - added TFileBufferWriter.Write1/Write4/Write8 methods and Tag property

  - new overloaded TFileBufferWriter.Create() constructor able to use a TStream

    class to replace CreateInRawByteStringStream and CreateInMemoryStream methods

  - now TFileBufferReader.Read() allows forward reading when Data=nil

  - added RecordSaveJSON() function which follows TTextWriter.AddRecordJSON() format

  - added SaveJSON() function to handle any kind of complex types from RTTI

  - added TSynNameValue.InitFromIniSection() method and optional default value

    parameter to TSynNameValue.Value()

  - added TSynNameValue.Delete() and SetBlobDataPtr() methods

  - added TSynNameValue.OnAfterAdd callback event

  - added TObjectListLocked class

  - expose all internal Hash*() functions (following TDynArrayHashOne prototype)

    in interface section of the unit

  - added crc32c() function using either optimized unrolled version, or SSE 4.2

    instruction: crc32cfast() is 1.7 GB/s, crc32csse42() is 3.7 GB/s

  - added fnv32() function, slower than kr32, but with less collisions

  - added SynLZCompress/SynLZDecompress functions, using crc32c() for hashing

  - added SymmetricEncrypt() function

  - added GetAllBits() function

  - changed GetBitCSV/SetBitCSV CSV format to use 'first-last,' pattern to

    regroup set bits (reduce storage size e.g. for TSQLAccessRights) - format

    is still compatible with old layout, but will more optimized and readable

  - TSynTableStatement.Create() SQL statement parser will handle optional

    LIMIT [OFFSET] clause (in new Limit/Offset integer properties),

    ORDER BY ... [DESC/ASC] clause (in new OrderByField/OrderByDesc properties),

    GROUP BY ... clause (in GroupByField property), "LIKE", "IN(...)" and

    "IS [NOT] NULL" operators and custom functions in the WHERE clause

  - TSynTableStatement.Where[] is now an array to allow complex WHERE clause

  - TSynTableStatement.Select[] is now an array to allow aggregate functions,

    (e.g. Count,Max or Distinct), column aliases, or simple +/- computation

  - introducing TSQLFieldIndex and TSQLFieldIndexDynArray types and associated

    functions so that TSynTableStatement would store the SELECT column order

  - SQLParamContent() / ExtractInlineParameters() functions moved from mORMot.pas

    (now properly handles SQL null and more than MAX_SQLFIELDS parameters)

  - introducing TSQLParamType / TSQLParamTypeDynArray generic parameters

  - added RemoveCommentsFromJSON() procedure - from MPV proposal

  - added GarbageCollectorFreeAndNil() procedure to handle global variables

    proper finalization to nil - avoid error [8e3073c8c7] and [8546b4af1d] e.g.

    when used as design package in Delphi IDE (for all globals and class VMTs)

  - made GarbageCollectorFree public - may be usefull e.g. with packages

  - added GlobalLock/GlobalUnlock functions, used e.g. for ticket [ea4e8bd544]

  - fixed rouding issue e.g. for ExtendedToString(double(22.99999999999997))

  - fixed potential GPF in TRawUTF8List.SetTextPtr() - ticket [d947b36cf9]

  - fixed potential GPF in function UrlDecodeNeedParameters()

  - fixed ticket [c8a8c71b12] allowing decoding of URI computed by browsers,

    even if they do not follow the RFC 3986 specifications

  - fixed potential GPF in serveral functions, when working with WideString

    (WideString aka OleStr do store their length in bytes, not WideChars)

  - fixed TDynArray.AddArray() method when Count parameter is not specified,

    and introducing TDynArray.AddDynArray() method

  - fixed ticket [ad55566b10] about JSON string escape parsing

  - fixed ticket [cce54e98ca], [388c2768b6] and [355249a9d1] about overflow in

    TTextWriter.AddJSONEscapeW()

  - fixed ticket [a75c0c6759] about TTextWriter.AddNoJSONEscapeW()

  - added TTextWriter.AddHtmlEscape() and TTextWriter.AddXmlEscape() methods

  - new TTextWriter.AddHtmlEscapeWiki() method, supporting wiki-like syntax

  - TTextWriter.AddJSONEscape/AddJSONEscapeW methods speed up

  - fixed ticket [01408fd389] in TRawUTF8List.GetText()

  - fixed ticket [e3ae1005dc] about potential GPF in TRawUTF8List.Delete()

  - fixed ticket [1c940a4437] to avoid negative value in TPrecisionTimer.PerSec,

    in case of incorrect Start/Stop methods sequence

  - implement ticket [e3f9742865] for enhanced JSON in soWriteHumanReadable mode

  - added TPrecisionTimer.ProfileCurrentMethod() and TimeInMicroSec property

    for feature request [1abca090ee]

  - added TLocalPrecisionTimer/ILocalPrecisionTimer to alllocate a local timer

    instance on the stack

  - fixed ticket [815facfe57] in UTF8ILComp()

  - fixed UTF8ToWideChar() functions to always append a WideChar(0) to the end

    of the destination buffer, even if returned length is 0

  - added AnyTextFileToString, AnyTextFileToSynUnicode and AnyTextFileToRawUTF8

  - declared PByteArray, PWordArray, PPointerArray here - see [d6b38a96e6]

  - fixed IdemPChar() in pure pascal to behave like the asm version (i.e.

    if up parameter is nil, will return TRUE)

  - added IdemPCharWithoutWhiteSpace() function

  - confusing-named RoundTo2Digits() function renamed into Trunc2ToDigit()

  - added simple, non banker rounding SimpleRoundTo2Digits() function

  - fixed potential comparison error in TSynTableFieldProperties.SortCompare()

    when sorting UTF8 Field with tfoCaseInsensitive in Options

  - speedup of QuotedStr() function and TDynArrayHashed hashing process

  - added GotoEndOfJSONString() function

  - added GetJSONPropName() and GotoNextJSONPropName() functions, able to

    understand MongoDB extended syntax

  - added JSONArrayCount/JSONObjectPropCount, JsonArayItem and

    JsonObjectItem/JsonObjectByPath/JsonObjectsByPath functions

  - several speedup in GetJSONField() and JSON parsing: it will now expect true,

    false or null to be in lowercase only (as in json.org specifications)

  - fixed function GetJSONField() to properly decode JSON number with exponent

  - added function GetJSONFieldOrObjectOrArray() in unit's interface section

  - function GotoNextJSONField() renamed GotoNextJSONItem(), and fixed to

    handle nested JSON array or objects in addition to string/numbers

  - added GotoEndJSONItem() and GetJSONItemAsRawJSON() functions

  - added function JSONRetrieveIDField() for fast retrieval of a "ID":.. value

  - added function JSONRetrieveStringField() for retrieval of a string field

    name or value from JSON buffer

  - added PtrUIntScanIndex() and UnixTimeToDateTime/DateTimeToUnixTime()

    UnixMSTimeToDateTime/DateTimeToUnixMSTime functions

  - fixed ticket [aff1352239] to identify 9999-12-31 dates as valid

  - added Iso8601ToTimePUTF8Char[Var]() and IntervalTextToDateTime[Var]() functions

  - added DateTimeToIso8601ExpandedPChar() and Iso8601CheckAndDecode() functions

  - added TTimeLogBits.FromUTCTime method and NowUTC / TimeLogNowUTC functions

  - added TTimeLogBits.FromUnixTime/FromUnixMSTime/ToUnixTime/ToUnixMSTime

  - added TTimeLogBits.Year/Month/Day/Hour/Minute/Second functions

  - added GetTickCount64() function, native since Vista, emulated e.g. for XP

  - introducing InterlockedIncrement/IntelrlockedDecrement compatibility functions

  - fixed TTextWriter.RegisterCustomJSONSerializer() method when unregistering

  - fixed TTextWriter.AddFloatStr() method when processing '-.5' input

  - fixed potential random GPF in TTextWriter after Flush - see [577ad95cfd0]

  - added TTextWriter.Add(const Values: array of const) method

  - added JSONToXML() JSONBufferToXML() and TTextWriter.JSONBufferToXML()

    for direct and fast conversion of any JSON into the corresponding <XML>

  - added JSONReformat() JSONBufferReformat() JSONReformatToFile()

    JSONBufferReformatToFile() and TTextWriter.AddJSONReformat()

    for fast conversion into more readable, compact or extended layout

  - fixed potential GPF issue in TMemoryMapText.LoadFromMap()

  - added TMemoryMapText.AddInMemoryLine method to allow runtime appending of

    new lines of text - used e.g. by TSynLogFile for life update of remote logs

  - added TMemoryMapText.SaveToFile() and TMemoryMapText.SaveToStream() methods

  - allow file size of 0 byte in TMemoryMap.Map()

  - introduced TSynInvokeableVariantType.Clear() and Copy() default methods

  - added TSynInvokeableVariantType.CopyByValue() virtual method

  - added TSynInvokeableVariantType.IsOfType() method

  - TSynInvokeableVariantType.SetProperty() will now convert any varOleStr into

    a RawUTF8/varString, and dereference any simple varByRef transmitted values

    so that we could safely use late-binding with any kind of value

  - internal DispInvoke() function speed-up by caching the latest accessed type

  - enabled DispInvoke() function for Delphi XE2 and up (it will also fix the

    regression issue in the new RTL which let the field names be uppercased)

  - several TSynTableFieldProperties speed up, when working with variants

  - removed several compilation hints when assertions are set to off

  - UnCamelCase() functions will now handle capital words and numbers at the

    beginning, middle or end of the text - implements request [d0c8210fae]

  - added TSynBackgroundThreadAbstract class for generic background process, and

    callback-driven TSynBackgroundThreadEvent / TSynBackgroundThreadProcedure /

    TSynBackgroundThreadMethod inherited classes

  - new TSynParallelProcess for parallel processing of indexed information

  - added SetThreadName/SetCurrentThreadName functions for request [6acfd0a3d3]

  - added TSynFPUException class to allow per-method customization of the FPU

    exception mapping: to be used e.g. when mixing code between external

    libraries and Delphi code

  - added new TSynValidateNonVoidText and TSynFilterTruncate classes

  - added Utf8TruncateToUnicodeLength() and Utf8TruncateToLength() functions

  - added MaxAlphaCount, MaxDigitCount, MaxPunctCount, MaxLowerCount and

    MaxUpperCount properties to TSynValidateText class

  - added ResourceToRawByteString and ResourceSynLZToRawByteString functions

  - if DOPATCHTRTL is defined, will enable asm-optimized RecordClear and

    _InitializeRecord functions in replacement to the slower RTL version, and

    patch TObject.CleanupInstance before Delphi 2009 (since TMonitor.Destroy

    is sadly private to System.pas)

  - introducing TSQLVar to define database-oriented values

    used by SynDB, mORMot, mORMotDB and mORMotSQLite3 units (instead of former

    confusing TVarData record, which is now dedicated to variant mapping)

  - moved TSQLDBFieldType from SynDB to SynCommons, and used by TSQLVar and all

    database-related process (i.e. in mORMot and SynDB units)

  - SYNOPSE_FRAMEWORK_VERSION constant will now include a per-commit increasing

    number (generated by SourceCodeRep tool), to specify the exact source state

    and a more complete SYNOPSE_FRAMEWORK_FULLVERSION constant has been added



*)





{$I Synopse.inc} // define HASINLINE USETYPEINFO CPU32 CPU64 OWNNORMTOUPPER



interface



uses

{$ifndef LVCL}

{$ifndef FPC}

{$ifndef HASFASTMM4}

  FastMM4,

{$endif}

{$endif}

{$endif}

{$ifdef MSWINDOWS}

  Windows,

  Messages,

  {$ifndef LVCL}

  Registry,

  {$endif}

{$else MSWINDOWS}

{$ifdef KYLIX3}

  Types,

  LibC,

  SynKylix,

{$endif}

{$ifdef FPC}

  BaseUnix,

{$endif}

{$endif MSWINDOWS}

  Classes,

{$ifndef LVCL}

  SyncObjs, // for TEvent and TCriticalSection

  Contnrs,  // for TObjectList

{$ifdef HASINLINE}

  Types,

{$endif}

{$endif}

{$ifndef NOVARIANTS}

  Variants,

{$endif}

  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 LVCL}+'_LVCL'{$else}

    {$ifdef ENHANCEDRTL}+' ERTL'{$endif}{$endif}

    {$ifdef DOPATCHTRTL}+' PRTL'{$endif}

    {$ifdef INCLUDE_FTS3}+' FTS3'{$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;



{$ifndef MSWINDOWS}

  /// estimate the system code page is WinAnsi

  GetACP = CODEPAGE_US;

  /// internal Code Page for UTF-8 Unicode encoding

  CP_UTF8 = 65001;

{$endif}



{$ifdef FPC} { make cross-compiler and cross-CPU types available to Delphi }



type

  PBoolean = ^Boolean;



{$else FPC}



type

  /// a CPU-dependent unsigned integer type cast of a pointer / register

  // - used for 64 bits compatibility, native under Free Pascal Compiler

{$ifdef ISDELPHI2009}

  PtrUInt = cardinal; { see http://synopse.info/forum/viewtopic.php?id=136 }

{$else}

  {$ifdef UNICODE}

  PtrUInt = NativeUInt;

  {$else}

  PtrUInt = cardinal;

  {$endif}

{$endif}

  /// a CPU-dependent unsigned integer type cast of a pointer of pointer

  // - used for 64 bits compatibility, native under Free Pascal Compiler

  PPtrUInt = ^PtrUInt;



  /// a CPU-dependent signed integer type cast of a pointer / register

  // - used for 64 bits compatibility, native under Free Pascal Compiler

{$ifdef ISDELPHI2009}

  PtrInt = integer;

{$else}

  {$ifdef UNICODE}

  PtrInt = NativeInt;

  {$else}

  PtrInt = integer;

  {$endif}

{$endif}

  /// a CPU-dependent signed integer type cast of a pointer of pointer

  // - used for 64 bits 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

  {$ifdef FPC_OR_UNICODE}

  QWord = UInt64;

  {$else}

  QWord = type 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 DELPHI5OROLDER}

  // Delphi 5 doesn't have those basic types defined :(

const

  varShortInt = $0010;

  varInt64 = $0014; { vt_i8 }

  soBeginning = soFromBeginning;

  soCurrent = soFromCurrent;

  reInvalidPtr = 2;

  PathDelim  = '\';

  sLineBreak = #13#10;



type

  PPointer = ^Pointer;

  PPAnsiChar = ^PAnsiChar;

  PInteger = ^Integer;

  PCardinal = ^Cardinal;

  PWord = ^Word;

  PByte = ^Byte;

  PBoolean = ^Boolean;

  PComp = ^Comp;

  THandle = LongWord;

  UInt64 = Int64;

  PVarData = ^TVarData;

  TVarData = packed record

    // mostly used for varNull, varInt64, varDouble, varString and varAny

    VType: word;

    case Integer of

      0: (Reserved1: Word;

          case Integer of

            0: (Reserved2, Reserved3: Word;

                case Integer of

                  varSmallInt: (VSmallInt: SmallInt);

                  varInteger:  (VInteger: Integer);

                  varSingle:   (VSingle: Single);

                  varDouble:   (VDouble: Double);     // DOUBLE

                  varCurrency: (VCurrency: Currency);

                  varDate:     (VDate: TDateTime);

                  varOleStr:   (VOleStr: PWideChar);

                  varDispatch: (VDispatch: Pointer);

                  varError:    (VError: HRESULT);

                  varBoolean:  (VBoolean: WordBool);

                  varUnknown:  (VUnknown: Pointer);

                  varByte:     (VByte: Byte);

                  varInt64:    (VInt64: Int64);      // INTEGER

                  varString:   (VString: Pointer);   // TEXT

                  varAny:      (VAny: Pointer);

                  varArray:    (VArray: PVarArray);

                  varByRef:    (VPointer: Pointer);

               );

            1: (VLongs: array[0..2] of LongInt); );

  end;

{$endif}



type

  /// a pointer to a PtrUInt array

  TPtrUIntArray = array[0..MaxInt div SizeOf(PtrUInt)-1] of PtrUInt;

  PPtrUIntArray = ^TPtrUIntArray;



  /// a dynamic array of PtrUInt values

  TPtrUIntDynArray = array of PtrUInt;



{$ifndef NOVARIANTS}

  /// a variant values array

  TVariantArray = array[0..MaxInt div SizeOf(Variant)-1] of Variant;

  /// a pointer to a variant array

  PVariantArray = ^TVariantArray;



  /// a dynamic array of variant values

  TVariantDynArray = array of variant;

{$endif}



  /// RawUnicode is an Unicode String stored in an AnsiString

  // - faster than WideString, which are allocated in Global heap (for COM)

  // - an AnsiChar(#0) is added at the end, for having a true WideChar(#0) at ending

  // - length(RawUnicode) returns memory bytes count: use (length(RawUnicode) shr 1)

  // for WideChar count (that's why the definition of this type since Delphi 2009

  // is AnsiString(1200) and not UnicodeString)

  // - pointer(RawUnicode) is compatible with Win32 'Wide' API call

  // - mimic Delphi 2009 UnicodeString, without the WideString or Ansi conversion overhead

  // - all conversion to/from AnsiString or RawUTF8 must be explicit: the

  // compiler is not able to make valid implicit conversion on CP_UTF16

  {$ifdef HASCODEPAGE}

  RawUnicode = type AnsiString(CP_UTF16); // Codepage for an UnicodeString

  {$else}

  RawUnicode = type AnsiString;

  {$endif}



  /// RawUTF8 is an UTF-8 String stored in an AnsiString

  // - use this type instead of System.UTF8String, which behavior changed

  // between Delphi 2009 compiler and previous versions: our implementation

  // is consistent and compatible with all versions of Delphi compiler

  // - mimic Delphi 2009 UTF8String, without the charset conversion overhead

  // - all conversion to/from AnsiString or RawUnicode must be explicit

  {$ifdef HASCODEPAGE}

  RawUTF8 = type AnsiString(CP_UTF8); // Codepage for an UTF8 string

  {$else}

  RawUTF8 = type AnsiString;

  {$endif}



  /// WinAnsiString is a WinAnsi-encoded AnsiString (code page 1252)

  // - use this type instead of System.String, which behavior changed

  // between Delphi 2009 compiler and previous versions: our implementation

  // is consistent and compatible with all versions of Delphi compiler

  // - all conversion to/from RawUTF8 or RawUnicode must be explicit

  {$ifdef HASCODEPAGE}

  WinAnsiString = type AnsiString(CODEPAGE_US); // WinAnsi Codepage

  {$else}

  WinAnsiString = type AnsiString;

  {$endif}



  {$ifdef HASCODEPAGE}

  {$ifdef FPC}

  // missing declaration

  PRawByteString = ^RawByteString;

  {$endif}

  {$else}

  /// define RawByteString, as it does exist in Delphi 2009+

  // - to be used for byte storage into an AnsiString

  // - use this type if you don't want the Delphi compiler not to do any

  // code page conversions when you assign a typed AnsiString to a RawByteString,

  // i.e. a RawUTF8 or a WinAnsiString

  RawByteString = type AnsiString;

  /// pointer to a RawByteString

  PRawByteString = ^RawByteString;

  {$endif}



  /// RawJSON will indicate that this variable content would stay in raw JSON

  // - i.e. won't be serialized into values

  // - could be any JSON content: number, string, object or array

  // - e.g. interface-based service will use it for efficient and AJAX-ready

  // transmission of TSQLTableJSON result

  RawJSON = type RawUTF8;



  /// SynUnicode is the fastest available Unicode native string type, depending

  //  on the compiler used

  // - this type is native to the compiler, so you can use Length() Copy() and

  //   such functions with it (this is not possible with RawUnicodeString type)

  // - before Delphi 2009+, it uses slow OLE compatible WideString

  //   (with our Enhanced RTL, WideString allocation can be made faster by using

  //   an internal caching mechanism of allocation buffers - WideString allocation

  //   has been made much faster since Windows Vista/Seven)

  // - starting with Delphi 2009, it uses fastest UnicodeString type, which

  //   allow Copy On Write, Reference Counting and fast heap memory allocation

  {$ifdef UNICODE}

  SynUnicode = UnicodeString;

  {$else}

  SynUnicode = WideString;

  {$endif}



  PRawUnicode = ^RawUnicode;

  PRawJSON = ^RawJSON;

  PRawUTF8 = ^RawUTF8;

  PWinAnsiString = ^WinAnsiString;

  PWinAnsiChar = type PAnsiChar;

  PSynUnicode = ^SynUnicode;



  /// a simple wrapper to UTF-8 encoded zero-terminated PAnsiChar

  // - PAnsiChar is used only for Win-Ansi encoded text

  // - the Synopse mORMot framework uses mostly this PUTF8Char type,

  // because all data is internaly stored and expected to be UTF-8 encoded

  PUTF8Char = type PAnsiChar;

  PPUTF8Char = ^PUTF8Char;



  /// a Row/Col array of PUTF8Char, for containing sqlite3_get_table() result

  TPUtf8CharArray = array[0..MaxInt div SizeOf(PUTF8Char)-1] of PUTF8Char;

  PPUtf8CharArray = ^TPUtf8CharArray;



  /// a pointer to a PAnsiChar array

  TPAnsiCharArray = array[0..MaxInt div SizeOf(PAnsiChar)-1] of PAnsiChar;

  PPAnsiCharArray = ^TPAnsiCharArray;



  /// a dynamic array of PUTF8Char pointers

  TPUTF8CharDynArray = array of PUTF8Char;



  /// a pointer to a RawUTF8 array

  TRawUTF8Array = array[0..MaxInt div SizeOf(RawUTF8)-1] of RawUTF8;

  PRawUTF8Array = ^TRawUTF8Array;



  /// a dynamic array of UTF-8 encoded strings

  TRawUTF8DynArray = array of RawUTF8;

  PRawUTF8DynArray = ^TRawUTF8DynArray;



  /// a dynamic array of dynamic array of UTF-8 encoded strings

  TRawUTF8DynArrayDynArray = array of TRawUTF8DynArray;



  /// a dynamic array of WinAnsi encoded strings

  TWinAnsiDynArray = array of WinAnsiString;

  PWinAnsiDynArray = ^TWinAnsiDynArray;



  /// a dynamic array of RawByteString

  TRawByteStringDynArray = array of RawByteString;



  /// a dynamic array of TVarRec, i.e. could match an "array of const" parameter

  TTVarRecDynArray = array of TVarRec;



  /// a dynamic array of generic VCL strings

  TStringDynArray = array of string;

  PStringDynArray = ^TStringDynArray;



  /// a dynamic array of TDateTime values

  TDateTimeDynArray = array of TDateTime;

  PDateTimeDynArray = ^TDateTimeDynArray;



  {$ifndef DELPHI5OROLDER}

  /// a dynamic array of interface values

  TInterfaceDynArray = array of IInterface;

  PInterfaceDynArray = ^TInterfaceDynArray;

  {$endif}



  /// a dynamic array of WideString values

  TWideStringDynArray = array of WideString;

  PWideStringDynArray = ^TWideStringDynArray;



  /// a dynamic array of SynUnicode values

  TSynUnicodeDynArray = array of SynUnicode;

  PSynUnicodeDynArray = ^TSynUnicodeDynArray;



  PIntegerDynArray = ^TIntegerDynArray;

  TIntegerDynArray = array of integer;

  PCardinalDynArray = ^TCardinalDynArray;

  TCardinalDynArray = array of cardinal;

  PSingleDynArray = ^TSingleDynArray;

  TSingleDynArray = array of Single;

  PInt64DynArray = ^TInt64DynArray;

  TInt64DynArray = array of Int64;

  PDoubleDynArray = ^TDoubleDynArray;

  TDoubleDynArray = array of double;

  PCurrencyDynArray = ^TCurrencyDynArray;

  TCurrencyDynArray = array of Currency;

  TWordDynArray = array of word;

  PWordDynArray = ^TWordDynArray;

  TByteDynArray = array of byte;

  PByteDynArray = ^TByteDynArray;

  TObjectDynArray = array of TObject;

  PObjectDynArray = ^TObjectDynArray;

  TPersistentDynArray = array of TPersistent;

  PPersistentDynArray = ^TPersistentDynArray;

  TPointerDynArray = array of pointer;

  PPointerDynArray = ^TPointerDynArray;

  TPPointerDynArray = array of PPointer;

  PPPointerDynArray = ^TPPointerDynArray;

  TMethodDynArray = array of TMethod;

  PMethodDynArray = ^TMethodDynArray;

  TObjectListDynArray = array of TObjectList;

  PObjectListDynArray = ^TObjectListDynArray;

  TFileNameDynArray = array of TFileName;

  PFileNameDynArray = ^TFileNameDynArray;

  TBooleanDynArray = array of boolean;

  PBooleanDynArray = ^TBooleanDynArray;



  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;



  TCardinalArray = array[0..MaxInt div SizeOf(cardinal)-1] of cardinal;

  PCardinalArray = ^TCardinalArray;



  TInt64Array = array[0..MaxInt div SizeOf(Int64)-1] of Int64;

  PInt64Array = ^TInt64Array;



  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;



  TRawByteStringArray = array[0..MaxInt div SizeOf(RawByteString)-1] of RawByteString;

  PRawByteStringArray = ^TRawByteStringArray;



  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;



  TGUIDDynArray = array of TGUID;



  PInt64Rec = ^Int64Rec;

  {$ifndef DELPHI5OROLDER}

  PIInterface = ^IInterface;

  {$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;



  PObject = ^TObject;





{ ************ fast UTF-8 / Unicode / Ansi types and conversion routines **** }



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

    function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; SourceChars: Cardinal): 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

    // - a #0 char is appended at the end (and result will point to it)

    // - this default implementation will use the Operating System APIs

    function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; SourceChars: Cardinal): 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;

    /// 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

    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;

      {$ifdef HASINLINE}inline;{$endif}

    /// 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

    function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; SourceChars: Cardinal): 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

    // - a #0 char is appended at the end (and result will point to it)

    function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; SourceChars: Cardinal): 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

    function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; SourceChars: Cardinal): PAnsiChar; override;

    /// conversion of a wide char into the corresponding Ansi character

    // - return -1 for an unknown WideChar in the current code page

    function WideCharToAnsiChar(wc: cardinal): integer;

    /// return TRUE if the supplied unicode buffer only contains characters of

    // the corresponding Ansi code page

    // - i.e. if the text can be displayed using this code page

    function IsValidAnsi(WideText: PWideChar; Length: integer): boolean; overload;

    /// return TRUE if the supplied unicode buffer only contains characters of

    // the corresponding Ansi code page

    // - i.e. if the text can be displayed using this code page

    function IsValidAnsi(WideText: PWideChar): boolean; overload;

    /// return TRUE if the supplied UTF-8 buffer only contains characters of

    // the corresponding Ansi code page

    // - i.e. if the text can be displayed using this code page

    function IsValidAnsiU(UTF8Text: PUTF8Char): boolean;

    /// return TRUE if the supplied UTF-8 buffer only contains 8 bits characters

    // of the corresponding Ansi code page

    // - i.e. if the text can be displayed with only 8 bit unicode characters

    // (e.g. no "tm" or such) within this code page

    function IsValidAnsiU8Bit(UTF8Text: PUTF8Char): boolean;

    /// direct access to the Ansi-To-Unicode lookup table

    // - use this array like AnsiToWide: array[byte] of word

    property AnsiToWide: TWordDynArray read fAnsiToWide;

    /// direct access to the Unicode-To-Ansi lookup table

    // - use this array like WideToAnsi: array[word] of byte

    // - any unhandled WideChar will return ord('?')

    property WideToAnsi: TByteDynArray read fWideToAnsi;

  end;



  /// a class to handle UTF-8 to/from Unicode translation

  // - match the TSynAnsiConvert signature, for code page CP_UTF8

  // - this class is mostly a non-operation for conversion to/from UTF-8

  TSynAnsiUTF8 = class(TSynAnsiConvert)

  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

    function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; SourceChars: Cardinal): 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

    // - a #0 char is appended at the end (and result will point to it)

    function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; SourceChars: Cardinal): 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 UTF-8 encoded buffer into a PAnsiChar UTF-8 buffer

    // - Dest^ buffer must be reserved with at least SourceChars bytes

    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

    // - internaly calls UTF8BufferToAnsi virtual method

    function UTF8ToAnsi(const UTF8: RawUTF8): RawByteString; override;

    /// convert any Ansi Text into an UTF-8 encoded String

    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

    function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; SourceChars: Cardinal): 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

    // - a #0 char is appended at the end (and result will point to it)

    function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; SourceChars: Cardinal): 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

    function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; SourceChars: Cardinal): PAnsiChar; override;

  end;



  /// implements a stack-based storage of some (UTF-8 or binary) text

  // - could be used e.g. to make a temporary copy when JSON would be

  // 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 text

  {$ifdef UNICODE}

  TSynTempBuffer = record

  {$else}

  TSynTempBuffer = object

  {$endif}

  public

    /// the text length, in bytes, excluding the trailing #0

    len: integer;

    /// where the text has been copied

    // - equals nil if len=0

    buf: pointer;

    /// initialize a temporary copy of the supplied text supplied as RawByteString

    procedure Init(const Source: RawByteString); overload;

    /// initialize a temporary copy of the supplied text buffer, ending with #0

    procedure Init(Source: PUTF8Char); overload;

    /// initialize a temporary copy of the supplied text buffer

    procedure Init(Source: pointer; SourceLen: integer); overload;

    /// initialize a new temporary buffer of a given number of bytes

    procedure Init(SourceLen: integer); overload;

    /// finalize the temporary storage

    procedure Done; {$ifdef HASINLINE}inline;{$endif}

  private

    tmp: array[0..4095] of AnsiChar;

  end;



  /// implements a stack-based writable storage of binary content

  // - memory allocation is performed via a TSynTempBuffer

  {$ifdef UNICODE}

  TSynTempWriter = record

  {$else}

  TSynTempWriter = object

  {$endif}

  private

    tmp: TSynTempBuffer;

  public

    /// the current writable position in tmp.buf

    pos: PAnsiChar;

    /// initialize a new temporary buffer of a given number of bytes

    // - if maxsize is left to its 0 default value, the default stack-allocated

    // memory size is used, i.e. 4 KB

    procedure Init(maxsize: integer=0);

    /// finalize the temporary storage

    procedure Done;

    /// append some binary to the internal buffer

    // - would raise an ESynException in case of potential overflow

    procedure wr(const val; len: integer);

    /// append some shortstring as binary to the internal buffer

    procedure wrss(const str: shortstring);

    /// append some 8-bit value as binary to the internal buffer

    procedure wrb(b: byte);

    /// append some 16-bit value as binary to the internal buffer

    procedure wrw(w: word);

    /// append some 32-bit value as binary to the internal buffer

    procedure wrint(int: integer);

    /// append some 32-bit/64-bit pointer value as binary to the internal buffer

    procedure wrptr(ptr: pointer);

    /// append some 32-bit/64-bit integer as binary to the internal buffer

    procedure wrptrint(int: PtrInt);

    /// append some fixed-value bytes as binary to the internal buffer

    // - returns a pointer to the first byte of the added memory chunk

    function wrfillchar(count: integer; value: byte): PAnsiChar;

    /// returns the current offset position in the internal buffer

    function Position: integer;

    /// returns the buffer as a RawByteString instance

    function AsBinary: RawByteString;

  end;



var

  /// global TSynAnsiConvert instance to handle WinAnsi encoding (code page 1252)

  // - this instance is global and instantied during the whole program life time

  // - it will be created from hard-coded values, and not using the system API,

  // since it appeared that some systems (e.g. in Russia) did tweak the registry

  // so that 1252 code page maps 1251 code page

  WinAnsiConvert: TSynAnsiFixedWidth;



  /// global TSynAnsiConvert instance to handle current system encoding

  // - this is the encoding as used by the AnsiString Delphi, so will be used

  // before Delphi 2009 to speed-up VCL string handling (especially for UTF-8)

  // - this instance is global and instantied during the whole program life time

  CurrentAnsiConvert: TSynAnsiConvert;



  /// global TSynAnsiConvert instance to handle UTF-8 encoding (code page CP_UTF8)

  // - this instance is global and instantied during the whole program life time

  UTF8AnsiConvert: TSynAnsiUTF8;





const

  /// HTTP header name for the content type, as defined in the corresponding RFC

  HEADER_CONTENT_TYPE = 'Content-Type: ';



  /// HTTP header name for the content type, in upper case

  // - as defined in the corresponding RFC

  // - could be used e.g. with IdemPChar() to retrieve the Content-Type value

  HEADER_CONTENT_TYPE_UPPER = 'CONTENT-TYPE: ';



  /// 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';



  /// HTTP header for MIME content type used for raw binary data

  BINARY_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+BINARY_CONTENT_TYPE;



var

  /// MIME content type used for JSON communication

  // - this global will be initialized with JSON_CONTENT_TYPE constant, to

  // avoid a memory allocation each time it is assigned to a variable

  JSON_CONTENT_TYPE_VAR: RawUTF8;



  /// HTTP header for MIME content type used for plain JSON

  // - this global will be initialized with JSON_CONTENT_TYPE_HEADER constant,

  // to avoid a memory allocation each time it is assigned to a variable

  JSON_CONTENT_TYPE_HEADER_VAR: RawUTF8;





/// faster equivalence to SetString() function for a RawUTF8

// - will reallocate the content in-place if the string refcount is 1

// - to be used instead of SetString() for "var" RawUTF8 parameters

// - for RawUTF8 function result, SetString is still faster:

// ! SynCommons.UInt32ToUtf8(Value: cardinal): RawUTF8; SetRawUTF8 245.64ms

// ! SynCommons.UInt32ToUtf8(Value: cardinal): RawUTF8; SetString  136.39ms

procedure SetRawUTF8(var Dest: RawUTF8; text: pointer; len: integer);



/// faster equivalence to SetString(s,nil,len) function for a RawUTF8

// - won't allocate the content if the string refcount is 1 and len matches

procedure FastNewRawUTF8(var s: RawUTF8; len: integer);



/// 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}



/// conversion of a wide char into a WinAnsi (CodePage 1252) char

// - return '?' for an unknown WideChar in code page 1252

function WideCharToWinAnsiChar(wc: cardinal): AnsiChar;

  {$ifdef HASINLINE}inline;{$endif}



/// conversion of a wide char into a WinAnsi (CodePage 1252) char index

// - return -1 for an unknown WideChar in code page 1252

function WideCharToWinAnsi(wc: cardinal): integer;

  {$ifdef HASINLINE}inline;{$endif}



/// return TRUE if the supplied buffer only contains 7-bits Ansi characters

function IsAnsiCompatible(PC: PAnsiChar): boolean; overload;



/// return TRUE if the supplied buffer only contains 7-bits Ansi characters

function IsAnsiCompatible(PC: PAnsiChar; Len: integer): boolean; overload;



/// return TRUE if the supplied buffer only contains 7-bits Ansi characters

function IsAnsiCompatible(PW: PWideChar): boolean; overload;



/// return TRUE if the supplied text only contains 7-bits Ansi characters

function IsAnsiCompatible(const Text: RawByteString): boolean; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// return TRUE if the supplied buffer only contains 7-bits Ansi characters

function IsAnsiCompatible(PW: PWideChar; Len: integer): boolean; overload;



/// return TRUE if the supplied unicode buffer only contains WinAnsi characters

// - i.e. if the text can be displayed using ANSI_CHARSET

function IsWinAnsi(WideText: PWideChar): boolean; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// return TRUE if the supplied unicode buffer only contains WinAnsi characters

// - i.e. if the text can be displayed using ANSI_CHARSET

function IsWinAnsi(WideText: PWideChar; Length: integer): boolean; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// return TRUE if the supplied UTF-8 buffer only contains WinAnsi characters

// - i.e. if the text can be displayed using ANSI_CHARSET

function IsWinAnsiU(UTF8Text: PUTF8Char): boolean;

  {$ifdef HASINLINE}inline;{$endif}



/// return TRUE if the supplied UTF-8 buffer only contains WinAnsi 8 bit characters

// - i.e. if the text can be displayed using ANSI_CHARSET with only 8 bit unicode

// characters (e.g. no "tm" or such)

function IsWinAnsiU8Bit(UTF8Text: PUTF8Char): boolean;

  {$ifdef HASINLINE}inline;{$endif}



/// UTF-8 encode one UTF-16 character into Dest

// - return the number of bytes written into Dest (i.e. 1,2 or 3)

// - this method does NOT handle UTF-16 surrogate pairs

function WideCharToUtf8(Dest: PUTF8Char; aWideChar: PtrUInt): integer;

  {$ifdef HASINLINE}inline;{$endif}



/// UTF-8 encode one UTF-16 encoded UCS4 character into Dest

// - return the number of bytes written into Dest (i.e. from 1 up to 6)

// - Source will contain the next UTF-16 character

// - this method DOES handle UTF-16 surrogate pairs

function UTF16CharToUtf8(Dest: PUTF8Char; var Source: PWord): integer;



/// UTF-8 encode one UCS4 character into Dest

// - return the number of bytes written into Dest (i.e. from 1 up to 6)

// - this method DOES handle UTF-16 surrogate pairs

function UCS4ToUTF8(ucs4: cardinal; Dest: PUTF8Char): integer;



/// direct conversion of an AnsiString with an unknown code page into an

// UTF-8 encoded String

// - will assume CurrentAnsiConvert.CodePage prior to Delphi 2009

// - newer UNICODE versions of Delphi will retrieve the code page from string

procedure AnyAnsiToUTF8(const s: RawByteString; var result: RawUTF8); overload;



/// direct conversion of an AnsiString with an unknown code page into an

// UTF-8 encoded String

// - will assume CurrentAnsiConvert.CodePage prior to Delphi 2009

// - newer UNICODE versions of Delphi will retrieve the code page from string

function AnyAnsiToUTF8(const s: RawByteString): RawUTF8; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// direct conversion of a WinAnsi (CodePage 1252) string into a UTF-8 encoded String

// - faster than SysUtils: don't use Utf8Encode(WideString) -> no Windows.Global(),

// and use a fixed pre-calculated array for individual chars conversion

function WinAnsiToUtf8(const S: WinAnsiString): RawUTF8; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// direct conversion of a WinAnsi (CodePage 1252) string into a UTF-8 encoded String

// - faster than SysUtils: don't use Utf8Encode(WideString) -> no Windows.Global(),

// and use a fixed pre-calculated array for individual chars conversion

function WinAnsiToUtf8(WinAnsi: PAnsiChar; WinAnsiLen: integer): RawUTF8; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// direct conversion of a WinAnsi PAnsiChar buffer into a UTF-8 encoded buffer

// - Dest^ buffer must be reserved with at least SourceChars*3

// - call internally WinAnsiConvert fast conversion class

function WinAnsiBufferToUtf8(Dest: PUTF8Char; Source: PAnsiChar; SourceChars: Cardinal): PUTF8Char;

  {$ifdef HASINLINE}inline;{$endif}



/// direct conversion of a WinAnsi shortstring into a UTF-8 text

// - call internally WinAnsiConvert fast conversion class

function ShortStringToUTF8(const source: ShortString): RawUTF8;

  {$ifdef HASINLINE}inline;{$endif}



/// direct conversion of a WinAnsi (CodePage 1252) string into a Unicode encoded String

// - very fast, by using a fixed pre-calculated array for individual chars conversion

function WinAnsiToRawUnicode(const S: WinAnsiString): RawUnicode;



/// direct conversion of a WinAnsi (CodePage 1252) string into a Unicode buffer

// - very fast, by using a fixed pre-calculated array for individual chars conversion

// - text will be truncated if necessary to avoid buffer overflow in Dest[]

procedure WinAnsiToUnicodeBuffer(const S: WinAnsiString; Dest: PWordArray; DestLen: integer);

  {$ifdef HASINLINE}inline;{$endif}



/// direct conversion of a UTF-8 encoded string into a WinAnsi String

function Utf8ToWinAnsi(const S: RawUTF8): WinAnsiString; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// direct conversion of a UTF-8 encoded zero terminated buffer into a WinAnsi String

function Utf8ToWinAnsi(P: PUTF8Char): WinAnsiString; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// direct conversion of a UTF-8 encoded zero terminated buffer into a RawUTF8 String

procedure Utf8ToRawUTF8(P: PUTF8Char; var result: RawUTF8);

  {$ifdef HASINLINE}inline;{$endif}



/// direct conversion of a UTF-8 encoded buffer into a WinAnsi PAnsiChar buffer

function UTF8ToWinPChar(dest: PAnsiChar; source: PUTF8Char; count: integer): integer;

  {$ifdef HASINLINE}inline;{$endif}



/// direct conversion of a UTF-8 encoded buffer into a WinAnsi shortstring buffer

procedure UTF8ToShortString(var dest: shortstring; source: PUTF8Char);



/// direct conversion of an ANSI-7 shortstring into an AnsiString

// - can be used e.g. for names retrieved from RTTI to convert them into RawUTF8

function ShortStringToAnsi7String(const source: shortstring): RawByteString; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// direct conversion of an ANSI-7 shortstring into an AnsiString

// - can be used e.g. for names retrieved from RTTI to convert them into RawUTF8

procedure ShortStringToAnsi7String(const source: shortstring; var result: RawUTF8); overload;

  {$ifdef HASINLINE}inline;{$endif}



/// convert an UTF-8 encoded text into a WideChar array

// - faster than System.UTF8ToUnicode

// - sourceBytes can by 0, therefore length is computed from zero terminated source

// - enough place must be available in dest

// - a WideChar(#0) is added at the end (if something is written)

// - returns the BYTE count written in dest, excluding the ending WideChar(#0)

function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; sourceBytes: PtrInt=0): PtrInt; overload;



/// convert an UTF-8 encoded text into a WideChar array

// - 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

// - a WideChar(#0) is added at the end (if something is written)

// - returns the BYTE COUNT (not WideChar count) written in dest, excluding the

// ending WideChar(#0)

function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; MaxDestChars, sourceBytes: PtrInt): 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

function IsValidUTF8(source: PUTF8Char): Boolean;



/// returns TRUE if the supplied buffer has valid UTF-8 encoding with no #1..#31

// control characters

function IsValidUTF8WithoutControlChars(source: PUTF8Char): Boolean;



/// 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

// UTF-8 Unicode characters 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; maxUTF8: cardinal): boolean;



/// 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;



/// convert a RawUnicode PWideChar into a UTF-8 string

procedure RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer; var result: RawUTF8); overload;



/// convert a RawUnicode PWideChar into a UTF-8 string

function RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer): RawUTF8; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// convert a RawUnicode PWideChar into a UTF-8 buffer

// - replace system.UnicodeToUtf8 implementation, which is rather slow

// since Delphi 2009+

function RawUnicodeToUtf8(Dest: PUTF8Char; DestLen: PtrInt; Source: PWideChar; SourceLen: PtrInt): PtrInt; overload;



/// convert a RawUnicode PWideChar into a UTF-8 string

// - this version doesn't resize the resulting RawUTF8 string, but return

// the new resulting RawUTF8 byte count into UTF8Length

function RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer; out UTF8Length: integer): RawUTF8; overload;



/// convert a RawUnicode string into a UTF-8 string

function RawUnicodeToUtf8(const Unicode: RawUnicode): RawUTF8; overload;



/// convert a SynUnicode string into a UTF-8 string

function SynUnicodeToUtf8(const Unicode: SynUnicode): RawUTF8;



/// convert a WideString into a UTF-8 string

function WideStringToUTF8(const aText: WideString): RawUTF8;

  {$ifdef HASINLINE}inline;{$endif}



/// direct conversion of a Unicode encoded buffer into a WinAnsi PAnsiChar buffer

procedure RawUnicodeToWinPChar(dest: PAnsiChar; source: PWideChar; WideCharCount: integer);

  {$ifdef HASINLINE}inline;{$endif}



/// convert a RawUnicode PWideChar into a WinAnsi (code page 1252) string

function RawUnicodeToWinAnsi(WideChar: PWideChar; WideCharCount: integer): WinAnsiString; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// convert a RawUnicode string into a WinAnsi (code page 1252) string

function RawUnicodeToWinAnsi(const Unicode: RawUnicode): WinAnsiString; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// convert a WideString into a WinAnsi (code page 1252) string

function WideStringToWinAnsi(const Wide: WideString): WinAnsiString;

  {$ifdef HASINLINE}inline;{$endif}



/// convert an AnsiChar buffer (of a given code page) into a UTF-8 string

procedure AnsiCharToUTF8(P: PAnsiChar; L: Integer; var result: RawUTF8; ACP: integer);



/// convert any Raw Unicode encoded String into a generic SynUnicode Text

function RawUnicodeToSynUnicode(const Unicode: RawUnicode): SynUnicode; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// convert any Raw Unicode encoded String into a generic SynUnicode Text

function RawUnicodeToSynUnicode(WideChar: PWideChar; WideCharCount: integer): SynUnicode; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// convert an Unicode buffer into a WinAnsi (code page 1252) string

procedure UnicodeBufferToWinAnsi(source: PWideChar; out Dest: WinAnsiString);



/// convert an Unicode buffer into a generic VCL string

function UnicodeBufferToString(source: PWideChar): string;



{$ifdef HASVARUSTRING}



/// convert a Delphi 2009+ or FPC Unicode string into our UTF-8 string

function UnicodeStringToUtf8(const S: UnicodeString): RawUTF8; inline;



// this function is the same as direct RawUTF8=AnsiString(CP_UTF8) assignment

// but is faster, since it uses no Win32 API call

function UTF8DecodeToUnicodeString(const S: RawUTF8): UnicodeString; overload; inline;



/// convert our UTF-8 encoded buffer into a Delphi 2009+ Unicode string

// - this function is the same as direct assignment, since RawUTF8=AnsiString(CP_UTF8),

// but is faster, since use no Win32 API call

procedure UTF8DecodeToUnicodeString(P: PUTF8Char; L: integer; var result: UnicodeString); overload;



/// convert a Delphi 2009+ Unicode string into a WinAnsi (code page 1252) string

function UnicodeStringToWinAnsi(const S: string): WinAnsiString; inline;



/// convert our UTF-8 encoded buffer into a Delphi 2009+ Unicode string

// - this function is the same as direct assignment, since RawUTF8=AnsiString(CP_UTF8),

// but is faster, since use no Win32 API call

function UTF8DecodeToUnicodeString(P: PUTF8Char; L: integer): UnicodeString; overload; inline;



/// convert a Win-Ansi encoded buffer into a Delphi 2009+ Unicode string

// - this function is faster than default RTL, since use no Win32 API call

function WinAnsiToUnicodeString(WinAnsi: PAnsiChar; WinAnsiLen: integer): UnicodeString; overload;



/// convert a Win-Ansi string into a Delphi 2009+ Unicode string

// - this function is faster than default RTL, since use no Win32 API call

function WinAnsiToUnicodeString(const WinAnsi: WinAnsiString): UnicodeString; inline; overload;



{$endif HASVARUSTRING}



/// convert any generic VCL Text into an UTF-8 encoded String

// - 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 StringToUTF8(const Text: string): 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(const guid: TGUID): RawUTF8; overload;



{$ifndef NOVARIANTS}



type

  /// function prototype used internally for variant comparaison

  // - used in mORMot.pas unit e.g. by TDocVariantData.SortByValue

  TVariantCompare = function(const V1,V2: variant): PtrInt;



/// convert any Variant into UTF-8 encoded String

// - use VariantSaveJSON() instead if you need a conversion to JSON with

// custom parameters

function VariantToUTF8(const V: Variant): RawUTF8; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// convert any Variant into UTF-8 encoded String

// - use VariantSaveJSON() instead if you need a conversion to JSON with

// custom parameters

function ToUTF8(const V: Variant): RawUTF8; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// convert any Variant into UTF-8 encoded String

// - use VariantSaveJSON() instead if you need a conversion to JSON with

// custom parameters

// - wasString is set if the V value was a text

// - custom variant types 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)

// - custom variant types 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 comparison of a Variant and UTF-8 encoded String

// - slightly faster than plain V=Str, which computes a temporary variant

function VariantEquals(const V: Variant; const Str: RawUTF8): 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 in 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);



{$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 fixed decimals floating point value

function VariantToCurrency(const V: Variant; var Value: currency): boolean;



/// convert any numerical Variant into a boolean value

function VariantToBoolean(const V: Variant; var Value: Boolean): boolean;



/// convert any numerical Variant into an integer

// - it will expect true numerical Variant and won't convert any string nor

// floating-pointer Variant, which will return the supplied DefaultValue

function VariantToIntegerDef(const V: Variant; DefaultValue: integer): integer; overload;



/// convert any generic VCL Text buffer into an UTF-8 encoded buffer

// - Dest must be able to receive at least SourceChars*3 bytes

// - it will work as is with Delphi 2009+ (direct unicode conversion)

// - under older version of Delphi (no unicode), it will use the

// current RTL codepage, as with WideString conversion (but without slow

// WideString usage)

function StringBufferToUtf8(Dest: PUTF8Char; Source: PChar; SourceChars: PtrInt): PUTF8Char;



/// 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;



/// convert any generic VCL Text into a Raw Unicode encoded String

// - it's prefered to use TLanguageFile.StringToUTF8() method in mORMoti18n,

// which will handle full i18n of your application

// - it will work as is with Delphi 2009+ (direct unicode conversion)

// - under older version of Delphi (no unicode), it will use the

// current RTL codepage, as with WideString conversion (but without slow

// WideString usage)

function StringToRawUnicode(P: PChar; L: integer): RawUnicode; overload;



/// convert any Raw Unicode encoded string into a generic VCL Text

function RawUnicodeToString(const U: RawUnicode): string; overload;



/// convert any Raw Unicode encoded buffer into a generic VCL Text

function RawUnicodeToString(P: PWideChar; L: integer): string; overload;



/// convert any Raw Unicode encoded buffer into a generic VCL Text

procedure RawUnicodeToString(P: PWideChar; L: integer; var result: string); overload;



/// convert any SynUnicode encoded string into a generic VCL Text

function SynUnicodeToString(const U: SynUnicode): string;

  {$ifdef HASINLINE}inline;{$endif}



/// convert any UTF-8 encoded String into a generic VCL Text

// - it's prefered to use TLanguageFile.UTF8ToString() in mORMoti18n,

// which will handle full i18n of your application

// - it will work as is with Delphi 2009+ (direct unicode conversion)

// - under older version of Delphi (no unicode), it will use the

// current RTL codepage, as with WideString conversion (but without slow

// WideString usage)

function UTF8ToString(const Text: RawUTF8): string;

  {$ifdef HASINLINE}inline;{$endif}



/// convert any UTF-8 encoded buffer into a generic VCL Text

// - it's prefered to use TLanguageFile.UTF8ToString() in mORMoti18n,

// which will handle full i18n of your application

// - it will work as is with Delphi 2009+ (direct unicode conversion)

// - under older version of Delphi (no unicode), it will use the

// current RTL codepage, as with WideString conversion (but without slow

// WideString usage)

function UTF8DecodeToString(P: PUTF8Char; L: integer): string; overload;

  {$ifdef UNICODE}inline;{$endif}



/// convert any UTF-8 encoded buffer into a generic VCL Text

procedure UTF8DecodeToString(P: PUTF8Char; L: integer; var result: string); overload;



/// convert any UTF-8 encoded String into a generic WideString Text

function UTF8ToWideString(const Text: RawUTF8): WideString; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// convert any UTF-8 encoded String into a generic WideString Text

procedure UTF8ToWideString(const Text: RawUTF8; var result: WideString); overload;

  {$ifdef HASINLINE}inline;{$endif}



/// convert any UTF-8 encoded String into a generic WideString Text

procedure UTF8ToWideString(Text: PUTF8Char; Len: integer; var result: WideString); overload;



/// convert any UTF-8 encoded String into a generic SynUnicode Text

function UTF8ToSynUnicode(const Text: RawUTF8): SynUnicode; overload;



/// convert any UTF-8 encoded String into a generic SynUnicode Text

procedure UTF8ToSynUnicode(const Text: RawUTF8; var result: SynUnicode); overload;



/// convert any UTF-8 encoded buffer into a generic SynUnicode Text

procedure UTF8ToSynUnicode(Text: PUTF8Char; Len: integer; var result: SynUnicode); overload;



/// convert any Ansi 7 bit encoded String into a generic VCL Text

// - the Text content must contain only 7 bit pure ASCII characters

function Ansi7ToString(const Text: RawByteString): string; overload;

  {$ifndef UNICODE}{$ifdef HASINLINE}inline;{$endif}{$endif}



/// convert any Ansi 7 bit encoded String into a generic VCL Text

// - the Text content must contain only 7 bit pure ASCII characters

function Ansi7ToString(Text: PWinAnsiChar; Len: integer): string; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// convert any Ansi 7 bit encoded String into a generic VCL Text

// - the Text content must contain only 7 bit pure ASCII characters

procedure Ansi7ToString(Text: PWinAnsiChar; Len: integer; var result: string); overload;



/// convert any generic VCL Text into Ansi 7 bit encoded String

// - the Text content must contain only 7 bit pure ASCII characters

function StringToAnsi7(const Text: string): RawByteString;



/// convert any generic VCL Text into WinAnsi (Win-1252) 8 bit encoded String

function StringToWinAnsi(const Text: string): WinAnsiString;

  {$ifdef UNICODE}inline;{$endif}



/// fast Format() function replacement, optimized for RawUTF8

// - only supported token is %, which will be inlined in the resulting string

// according to each Args[] supplied item

// - resulting string has no length limit and uses fast concatenation

// - note that cardinal values should be type-casted to Int64() (otherwise

// the integer mapped value will be transmitted, therefore wrongly)

// - 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 string on stack

procedure FormatUTF8(const Format: RawUTF8; const Args: array of const;

  var result: RawUTF8); overload;



/// 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 cardinal values should be type-casted to Int64() (otherwise

// the integer mapped value will be transmitted, therefore wrongly)

// - 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;



/// convert an open array (const Args: array of const) argument to an UTF-8

// encoded text

// - note that cardinal values should be type-casted to Int64() (otherwise

// the signed integer mapped value will be transmitted, therefore wrongly)

// - 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 avoid a temporary RawUTF8 allocation

  // - used by VarRecToTempUTF8() and FormatUTF8()

  TTempUTF8 = record

    Text: PUTF8Char;

    Len: integer;

    Temp: array[0..23] of AnsiChar;

  end;



/// 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 tmpStr only if needed,

// but use the supplied Res.Temp[] buffer for numbers to text conversion

// - it would return the number of UTF-8 bytes, i.e. Res.Len 

// - note that cardinal values should be type-casted to Int64() (otherwise

// the signed integer mapped value will be transmitted, therefore wrongly)

// - any supplied TObject instance will be written as their class name

function VarRecToTempUTF8(const V: TVarRec; var tmpStr: RawUTF8; 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 cardinal values should be type-casted to Int64() (otherwise

// the signed integer mapped value will be transmitted, therefore wrongly)

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 cardinal values should be type-casted to Int64() (otherwise

// the signed integer mapped value will be transmitted, therefore wrongly)

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 cardinal values should be type-casted to Int64() (otherwise

// the signed integer mapped value will be transmitted, therefore wrongly)

// - any supplied TObject instance will be written as their class name

procedure VarRecToInlineValue(const V: TVarRec; var result: RawUTF8);



/// get an open array (const Args: array of const) character argument

// - only handle varChar and varWideChar kind of arguments

function VarRecAsChar(const V: TVarRec): integer;

  {$ifdef HASINLINE}inline;{$endif}



type

  /// function prototype used internally for UTF-8 buffer comparaison

  // - used in mORMot.pas unit during TSQLTable rows sort and by TSQLQuery

  TUTF8Compare = function(P1,P2: PUTF8Char): PtrInt;



/// convert the endianness of a given unsigned 32 bit integer into BigEndian

function bswap32(a: cardinal): cardinal;



{$ifndef ISDELPHI2007ANDUP}

type

  TBytes = array of byte;

{$endif}



/// 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

procedure ResourceToRawByteString(const ResName: string; ResType: PChar;

  out buf: RawByteString);



/// 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)

procedure ResourceSynLZToRawByteString(const ResName: string;

  out buf: RawByteString);



{$ifndef ENHANCEDRTL} { is our Enhanced Runtime (or LVCL) library not installed? }



/// fast dedicated RawUTF8 version of Trim()

// - implemented using x86 asm, if possible

// - this Trim() is seldom used, but this RawUTF8 specific version is needed

// e.g. by Delphi 2009+, to avoid two unnecessary conversions into UnicodeString

function Trim(const S: RawUTF8): RawUTF8;



{$define OWNNORMTOUPPER} { NormToUpper[] exists only in our enhanced RTL }



{$ifndef PUREPASCAL}

{$ifndef LVCL} { don't define these functions twice }



/// use our fast asm version of CompareMem()

function CompareMem(P1, P2: Pointer; Length: Integer): Boolean;



{$endif LVCL}

{$endif PUREPASCAL}



{$endif ENHANCEDRTL}



/// convert some ASCII-7 text into binary, using Emile Baudot code

// - as used in telegraphs, covering a-z 0-9 - ' , ! : ( + ) $ ? @ . / ; charset

// - also #13 and #10 control chars will be transcoded

// - any upper case char will be converted into lowercase during encoding

// - other characters (e.g. UTF-8 accents, or controls chars) will be ignored

// - resulting binary will consume 5 (or 10) bits per character

// - reverse of the BaudotToAscii() function

// - the "baud" symbol rate measurement comes from Emile's name ;)

function AsciiToBaudot(P: PAnsiChar; len: integer): RawByteString; overload;



/// convert some ASCII-7 text into binary, using Emile Baudot code

// - as used in telegraphs, covering a-z 0-9 - ' , ! : ( + ) $ ? @ . / ; charset

// - also #13 and #10 control chars will be transcoded

// - any upper case char will be converted into lowercase during encoding

// - other characters (e.g. UTF-8 accents, or controls chars) will be ignored

// - resulting binary will consume 5 (or 10) bits per character

// - reverse of the BaudotToAscii() function

// - the "baud" symbol rate measurement comes from Emile's name ;)

function AsciiToBaudot(const Text: RawUTF8): RawByteString; overload;



/// convert some Baudot code binary, into ASCII-7 text

// - reverse of the AsciiToBaudot() function

// - any uppercase character would be decoded as lowercase - and some characters

// may have disapeared

// - the "baud" symbol rate measurement comes from Emile's name ;)

function BaudotToAscii(Baudot: PByteArray; len: integer): RawUTF8; overload;



/// convert some Baudot code binary, into ASCII-7 text

// - reverse of the AsciiToBaudot() function

// - any uppercase character would be decoded as lowercase - and some characters

// may have disapeared

// - the "baud" symbol rate measurement comes from Emile's name ;)

function BaudotToAscii(const Baudot: RawByteString): RawUTF8; overload;



{$ifdef UNICODE}

/// our fast RawUTF8 version of Pos(), for Unicode only compiler

// - this Pos() is seldom used, but this RawUTF8 specific version is needed

// by Delphi 2009+, to avoid two unnecessary conversions into UnicodeString

// - just a wrapper around PosEx(substr,str,1)

function Pos(const substr, str: RawUTF8): Integer; overload; inline;

{$endif UNICODE}



/// use our fast RawUTF8 version of IntToStr()

// - without any slow UnicodeString=String->AnsiString conversion for Delphi 2009

// - only useful if our Enhanced Runtime (or LVCL) library is not installed

function Int64ToUtf8(Value: Int64): RawUTF8; overload;

  {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif}



/// 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: integer): 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: integer; 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: cardinal): RawUTF8; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// optimized conversion of a cardinal into RawUTF8

procedure UInt32ToUtf8(Value: cardinal; 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;



var

  /// best possible precision when rendering a "single" kind of float

  // - can be used as parameter for ExtendedToString/ExtendedToStr

  // - is defined as a var, so that you may be able to override the default

  // settings, for the whole process

  SINGLE_PRECISION: integer = 8;

  /// best possible precision when rendering a "double" kind of float

  // - can be used as parameter for ExtendedToString/ExtendedToStr

  // - is defined as a var, so that you may be able to override the default

  // settings, for the whole process

  DOUBLE_PRECISION: integer = 15;

  /// best possible precision when rendering a "extended" kind of float

  // - can be used as parameter for ExtendedToString/ExtendedToStr

  // - is defined as a var, so that you may be able to override the default

  // settings, for the whole process

  EXTENDED_PRECISION: integer = 18;



type

  {$ifdef CPUARM}

  // ARM does not support 80bit extended -> 64bit double is enough for us

  TSynExtended = double;

  {$else}

  {$ifdef CPU64}

  TSynExtended = double;

  {$else}

  /// the floating-point type to be used for best precision and speed

  // - will allow to fallback to double e.g. on x64 and ARM CPUs

  TSynExtended = extended;

  {$endif}

  {$endif}



/// convert a floating-point value to its numerical text equivalency

// - returns the count of chars stored into S (S[0] is not set)

function ExtendedToString(var S: ShortString; Value: TSynExtended; Precision: integer): integer;



/// convert a floating-point value to its numerical text equivalency

function ExtendedToStr(Value: TSynExtended; Precision: integer): RawUTF8; overload;



/// convert a floating-point value to its numerical text equivalency

procedure ExtendedToStr(Value: TSynExtended; Precision: integer; var result: RawUTF8); overload;



/// convert a floating-point value to its numerical text equivalency

function DoubleToStr(Value: Double): RawUTF8;



/// fast retrieve the position of a given character

function PosChar(Str: PUTF8Char; Chr: AnsiChar): PUTF8Char;



/// fast retrieve the position of any value of a given set of characters

function PosCharAny(Str: PUTF8Char; Characters: PAnsiChar): PUTF8Char;



/// a non case-sensitive RawUTF8 version of Pos()

// - uppersubstr is expected to be already in upper case

// - this version handle only 7 bit ASCII (no accentuated characters)

function PosI(uppersubstr: PUTF8Char; const str: RawUTF8): Integer;



/// 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 : integer): RawUTF8;

//  !var tmp: array[0..15] of AnsiChar;

//  !    P: PAnsiChar;

//  !begin

//  !  P := StrInt32(@tmp[15],Value);

//  !  SetString(result,P,@tmp[15]-P);

//  !end;

// - not to be called directly: use IntToStr() 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^)

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;



{$ifdef PUREPASCAL}

/// inlined StrComp(), to be used with PUTF8Char/PAnsiChar

function StrComp(Str1, Str2: pointer): PtrInt;

  {$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 HASINLINE}inline;{$endif}

{$else}



/// x86 asm version of StrComp(), to be used with PUTF8Char/PAnsiChar

// - this version won't access the memory beyond the string, so may be

// preferred to StrcompSSE42 or StrComp, when using e.g. mapped files

function StrCompFast(Str1, Str2: pointer): PtrInt;



/// 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 can in principle

// generate a protection violation (e.g. when used over mapped files) - in this

// case, you can use the slightly slower StrCompFast() function instead

function StrCompSSE42(Str1, Str2: pointer): PtrInt;



/// fastest available version of StrComp(), to be used with PUTF8Char/PAnsiChar

// - will use SSE4.2 instructions on supported CPUs - and potentiall read up

// to 15 bytes beyond the string: use StrCompFast() for a safe memory read

var StrComp: function (Str1, Str2: pointer): PtrInt = StrCompFast;



{$endif}



/// 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. mapped files or any memory

// protected buffer

function StrLenPas(S: pointer): PtrInt;



{$ifdef FPC}

/// FPC will use its internal optimized implementations

function StrLen(S: pointer): sizeint; external name 'FPC_PCHAR_LENGTH';

var FillcharFast: procedure(var Dest; count: PtrInt; Value: byte) = System.FillChar;

{$else}



/// our fast version of StrLen(), to be used with PUTF8Char/PAnsiChar

// - this version will use fast SSE2/SSE4.2 instructions (if available), on both

// Win32 and Win64 platforms: please note that in this case, it may read up to

// 15 bytes before or beyond the string; this is rarely a problem but it can in

// principle generate a protection violation (e.g. when used over mapped files):

// you can use the slightly slower StrLenPas() function instead with such input

var StrLen: function(S: pointer): PtrInt = StrLenPas;



/// our fast version of FillChar()

// - this version will use fast SSE2 instructions (if available), on both Win32

// and Win64 platforms, or an optimized X86 revision on older CPUs

var FillcharFast: procedure(var Dest; count: PtrInt; Value: byte);



{$endif FPC}





/// our fast version of move()

// - this version will use fast SSE2 instructions (if available), on both Win32

// and Win64 platforms, or an optimized X86 revision on older CPUs

var MoveFast: procedure(const Source; var Dest; Count: PtrInt);



/// our fast version of StrLen(), to be used with PWideChar

function StrLenW(S: PWideChar): PtrInt;



/// use our fast version of StrComp(), to be used with PWideChar

function StrCompW(Str1, Str2: PWideChar): PtrInt;

  {$ifdef HASINLINE}inline;{$endif}



/// use our fast version of StrCompL(), to be used with PUTF8Char

function StrCompL(P1,P2: PUTF8Char; L, Default: Integer): PtrInt;

  {$ifdef HASINLINE}inline;{$endif}



/// use our fast version of StrCompIL(), to be used with PUTF8Char

function StrCompIL(P1,P2: PUTF8Char; L: Integer; Default: Integer=0): PtrInt;

  {$ifdef HASINLINE}inline;{$endif}



{$ifdef USENORMTOUPPER}

{$ifdef OWNNORMTOUPPER}

type

  TNormTable = packed array[AnsiChar] of AnsiChar;

  TNormTableByte = packed array[byte] of byte;



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;



/// get the signed 32 bits integer value stored in P^

// - we use the PtrInt result type, even if expected to be 32 bits, to use

// native CPU register size (don't want any 32 bits overflow here)

// - it will stop the parsing when P^ does not contain numbers any more

function GetInteger(P: PUTF8Char): PtrInt; overload;



/// get the signed 32 bits 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 bits 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 bits integer value stored in P^

// - we use the PtrUInt result type, even if expected to be 32 bits, to use

// native CPU register size (don't want any 32 bits overflow here)

function GetCardinal(P: PUTF8Char): PtrUInt;



/// get the unsigned 32 bits 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 bits 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 bits integer value stored in P^

function GetInt64(P: PUTF8Char): Int64; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// get the 64 bits integer value stored in P^

procedure SetInt64(P: PUTF8Char; var result: Int64);

  {$ifdef CPU64}inline;{$endif}



/// get the 64 bits 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 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;



/// 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 bits integer value stored in a RawUTF8 string

// - we use the PtrInt result type, even if expected to be 32 bits, to use

// native CPU register size (don't want any 32 bits overflow here)

function UTF8ToInteger(const value: RawUTF8; Default: PtrInt=0): PtrInt; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// get and check range of a signed 32 bits integer stored in a RawUTF8 string

// - we use the PtrInt result type, even if expected to be 32 bits, to use

// native CPU register size (don't want any 32 bits overflow here)

function UTF8ToInteger(const value: RawUTF8; Min,Max: PtrInt; Default: PtrInt=0): PtrInt; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// encode a string to be compatible with URI encoding

function UrlEncode(const svar: RawUTF8): RawUTF8; overload;



/// encode a string to be compatible with URI encoding

function UrlEncode(Text: PUTF8Char): RawUTF8; overload;



/// encode supplied parameters to be compatible with URI encoding

// - parameters must be supplied two by two, as Name,Value pairs, e.g.

// ! url := UrlEncode(['select','*','where','ID=12','offset',23,'object',aObject]);

// - parameters names should be plain ASCII-7 RFC compatible identifiers

// (0..9a..zA..Z_.~), otherwise their values are skipped

// - parameters values can be either textual, integer or extended, or any TObject

// - TObject serialization into UTF-8 will be processed by the ObjectToJSON()

// function

function UrlEncode(const NameValuePairs: array of const): RawUTF8; overload;



/// encode a JSON object UTF-8 buffer into URI parameters

// - you can specify property names to ignore during the object decoding

function UrlEncodeJsonObject(const URIName: RawUTF8; ParametersJSON: PUTF8Char;

  const PropNamesToIgnore: array of RawUTF8): RawUTF8;



/// decode a string compatible with URI encoding into its original value

// - you can specify the decoding range (as in copy(s,i,len) function)

function UrlDecode(const s: RawUTF8; i: PtrInt = 1; len: PtrInt = -1): RawUTF8; overload;



/// decode a string compatible with URI encoding into its original value

function UrlDecode(U: PUTF8Char): RawUTF8; overload;



/// decode a specified parameter compatible with URI encoding into its original

// textual value

// - UrlDecodeValue('select=%2A&where=LastName%3D%27M%C3%B4net%27','SELECT=',V,@Next)

// will return Next^='where=...' and V='*'

// - if Upper is not found, Value is not modified, and result is FALSE

// - if Upper is found, Value is modified with the supplied content, and result is TRUE

function UrlDecodeValue(U: PUTF8Char; Upper: PAnsiChar; 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; Upper: PAnsiChar;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; Upper: PAnsiChar;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; Upper: PAnsiChar;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; Upper: PAnsiChar; 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; Upper: PAnsiChar; 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;



/// 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,0..9,_ characters

// - use it with property names values (i.e. only including A..Z,0..9,_ chars)

// - 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 buffer contains simple characters as

// recognized by JSON extended syntax

// - follow GetJSONPropName and GotoNextJSONObjectOrArray expectations

function JsonPropNameValid(P: PUTF8Char): boolean;

  {$ifdef HASINLINE}inline;{$endif}



/// returns TRUE if the given text buffers would be escaped when written as JSON

// - e.g. if contains " or \ characters, as defined by

// http://www.ietf.org/rfc/rfc4627.txt 

function NeedsJsonEscape(const Text: RawUTF8): boolean;



/// case unsensitive test of P1 and P2 content

// - 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 unsensitive test of P1 and P2 content

// - 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: integer): boolean; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// case unsensitive test of P1 and P2 content

// - 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: integer): boolean; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// case unsensitive test of P1 and P2 content

// - 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: integer): boolean; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// case unsensitive test of P1 and P2 content 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: integer): boolean;

  {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif}



/// case unsensitive test of P1 and P2 content

// - 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;



/// 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;



/// returns true if the file name extension contained in p^ is the same same as extup^

// - ignore case - extup^ must be already Upper

// - chars are compared as WinAnsi (codepage 1252), not as UTF-8

// - could be used e.g. like IdemFileExt(aFileName,'.JP');

function IdemFileExt(p: PUTF8Char; extup: PAnsiChar; sepChar: AnsiChar='.'): Boolean;



/// internal function, used to retrieve a UCS4 char (>127) from UTF-8

// - not to be called directly, but from inlined higher-level functions

// - here U^ shall be always >= #80

function GetHighUTF8UCS4(var U: PUTF8Char): cardinal;



/// 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): cardinal;

  {$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;



const

  /// used e.g. by inlined function GetLineContains()

  ANSICHARNOT01310: set of AnsiChar = [#1..#9,#11,#12,#14..#255];



/// 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

// - will use SSE4.2 instructions on supported CPUs - and potentiall read up

// to 15 bytes beyond the string: use UpperCopy255BufPas() for a safer memory read

// - 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)

var UpperCopy255Buf: function(dest: PAnsiChar; source: PUTF8Char; sourceLen: integer): 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: integer): PAnsiChar;



{$ifndef PUREPASCAL}

{$ifndef DELPHI5OROLDER}



/// 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 will use SSE4.2 instructions on supported CPUs - and potentiall

// read up to 15 bytes beyond the string

// - 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 UpperCopy255BufSSE42(dest: PAnsiChar; source: PUTF8Char; sourceLen: integer): PAnsiChar;



{$endif}

{$endif}



/// copy source into dest^ with WinAnsi 8 bits upper case conversion

// - used internally for short keys match or case-insensitive hash

// - returns final dest pointer

// - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of

// AnsiChar)

function UpperCopyWin255(dest: PWinAnsiChar; const source: RawUTF8): PWinAnsiChar;



/// copy WideChar source into dest^ with upper case conversion

// - used internally for short keys match or case-insensitive hash

// - returns final dest pointer

// - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of

// AnsiChar)

function UpperCopy255W(dest: PAnsiChar; const source: SynUnicode): PAnsiChar; overload;



/// copy WideChar source into dest^ with upper case conversion

// - used internally for short keys match or case-insensitive hash

// - returns final dest pointer

// - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of

// AnsiChar)

function UpperCopy255W(dest: PAnsiChar; source: PWideChar; L: integer): PAnsiChar; overload;



/// copy source into dest^ with 7 bits upper case conversion

// - returns final dest pointer

// - will copy up to the source buffer end: so Dest^ should be big enough -

// which will the case e.g. if Dest := pointer(source)

function UpperCopy(dest: PAnsiChar; const source: RawUTF8): PAnsiChar;



/// copy source into dest^ with 7 bits upper case conversion

// - returns final dest pointer

// - this special version expect source to be a shortstring

function UpperCopyShort(dest: PAnsiChar; const source: shortstring): PAnsiChar;



{$ifdef USENORMTOUPPER}



/// fast UTF-8 comparaison using the NormToUpper[] array for all 8 bits values

// - this version expects u1 and u2 to be zero-terminated

// - this version will decode each UTF-8 glyph before using NormToUpper[]

// - current implementation handles UTF-16 surrogates

function UTF8IComp(u1, u2: PUTF8Char): PtrInt;



/// copy WideChar source into dest^ with upper case conversion, using the

// NormToUpper[] array for all 8 bits values, encoding the result as UTF-8

// - returns final dest pointer

// - current implementation handles UTF-16 surrogates

function UTF8UpperCopy(Dest, Source: PUTF8Char; SourceChars: Cardinal): PUTF8Char;



/// copy WideChar source into dest^ with upper case conversion, using the

// NormToUpper[] array for all 8 bits values, encoding the result as UTF-8

// - returns final dest pointer

// - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of

// AnsiChar), with UTF-8 encoding

function UTF8UpperCopy255(dest: PAnsiChar; const source: RawUTF8): PUTF8Char;

  {$ifdef HASINLINE}inline;{$endif}



/// fast UTF-8 comparaison using the NormToUpper[] array for all 8 bits values

// - this version expects u1 and u2 not to be necessary zero-terminated, but

// uses L1 and L2 as length for u1 and u2 respectively

// - use this function for SQLite3 collation (TSQLCollateFunc)

// - this version will decode the UTF-8 content before using NormToUpper[]

// - current implementation handles UTF-16 surrogates

function UTF8ILComp(u1, u2: PUTF8Char; L1,L2: cardinal): PtrInt;



/// fast case-insensitive Unicode comparaison

// - use the NormToUpperAnsi7Byte[] array, i.e. compare 'a'..'z' as 'A'..'Z'

// - this version expects u1 and u2 to be zero-terminated

function AnsiICompW(u1, u2: PWideChar): PtrInt;



/// SameText() overloaded function with proper UTF-8 decoding

// - fast version using NormToUpper[] array for all Win-Ansi characters

// - this version will decode each UTF-8 glyph before using NormToUpper[]

// - current implementation handles UTF-16 surrogates as UTF8IComp()

function SameTextU(const S1, S2: RawUTF8): Boolean;

  {$ifdef HASINLINE}inline;{$endif}



/// fast conversion of the supplied text into 8 bit uppercase

// - this will not only convert 'a'..'z' into 'A'..'Z', but also accentuated

// latin characters ('e' acute into 'E' e.g.), using NormToUpper[] array

// - it will 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 convert 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}



/// fast conversion of the supplied text into uppercase

// - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and

// will therefore by 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 by correct with true UTF-8 content, but only for 7 bit

procedure UpperCaseCopy(Text: PUTF8Char; Len: integer; var result: RawUTF8); overload;



/// fast conversion of the supplied text into uppercase

// - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and

// will therefore by correct with true UTF-8 content, but only for 7 bit

procedure UpperCaseCopy(const Source: RawUTF8; var Dest: RawUTF8); overload;



/// fast conversion of the supplied text into lowercase

// - this will only convert 'A'..'Z' into 'a'..'z' (no NormToLower use), and

// will therefore by 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 by correct with true UTF-8 content

procedure LowerCaseCopy(Text: PUTF8Char; Len: integer; var result: RawUTF8);



/// accurate conversion of the supplied UTF-8 content into the corresponding

// upper-case Unicode characters

// - this version will use the Operating System API, and will therefore be

// much slower than UpperCase/UpperCaseU versions, but will handle all

// kind of unicode characters

function UpperCaseUnicode(const S: RawUTF8): RawUTF8;



/// accurate conversion of the supplied UTF-8 content into the corresponding

// lower-case Unicode characters

// - this version will use the Operating System API, and will therefore be

// much slower than LowerCase/LowerCaseU versions, but will handle all

// kind of unicode characters

function LowerCaseUnicode(const S: RawUTF8): RawUTF8;



///  trims leading whitespace characters from the string by removing

// new line, space, and tab characters

function TrimLeft(const S: RawUTF8): RawUTF8;



/// trims trailing whitespace characters from the string by removing trailing

// newline, space, and tab characters

function TrimRight(const S: RawUTF8): RawUTF8;



/// fast WinAnsi comparaison using the NormToUpper[] array for all 8 bits values

function AnsiIComp(Str1, Str2: PWinAnsiChar): PtrInt;

  {$ifndef USENORMTOUPPER} {$ifdef PUREPASCAL}

  {$ifdef HASINLINE}inline;{$endif} {$endif} {$endif}



/// extract a line from source array of chars

// - next will contain the beginning of next line, or nil if source if ended

function GetNextLine(source: PUTF8Char; out next: PUTF8Char): RawUTF8;



{$ifdef UNICODE}

/// extract a line from source array of chars

// - next will contain the beginning of next line, or nil if source if ended

// - this special version expect UnicodeString pointers, and return an UnicodeString

function GetNextLineW(source: PWideChar; out next: PWideChar): string;



/// find the Value of UpperName in P, till end of current section

// - expect UpperName as 'NAME='

// - this special version expect UnicodeString pointer, and return a VCL string

function FindIniNameValueW(P: PWideChar; UpperName: PUTF8Char): string;



/// find a Name= Value in a [Section] of a INI Unicode Content

// - this function scans the Content memory buffer, and is

// therefore very fast (no temporary TMemIniFile is created)

// - if Section equals '', find the Name= value before any [Section]

function FindIniEntryW(const Content: string; const Section, Name: RawUTF8): string;



{$ifdef PUREPASCAL}



{$ifndef 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

function Pos(const substr, str: RawUTF8): Integer; overload; inline;

{$endif UNICODE}



{$else}



{$endif PUREPASCAL}



{$endif UNICODE}



/// faster RawUTF8 Equivalent of standard StrUtils.PosEx

function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt=1): Integer;



/// 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 exluding) SepStr

// - if SepStr is not found, returns Str

function Split(const Str, SepStr: RawUTF8; StartPos: integer=1): RawUTF8; overload;



/// split a RawUTF8 string into several strings, according to SepStr separator

// - this overloaded function will fill a DestPtr[] array of PRawUTF8

// - if any DestPtr[]=nil, the item will be skipped

procedure Split(const Str: RawUTF8; const SepStr: array of RawUTF8;

  const DestPtr: array of PRawUTF8); overload;



/// fast version of StringReplace(S, OldPattern, NewPattern,[rfReplaceAll]);

function StringReplaceAll(const S, OldPattern, NewPattern: RawUTF8): RawUTF8;



/// fast replace of a specified char by a given string

function StringReplaceChars(const Source: RawUTF8; OldChar, NewChar: AnsiChar): RawUTF8;



/// fast replace of all #9 chars by a given string

function StringReplaceTabs(const Source,TabText: RawUTF8): RawUTF8;



/// format a text content with SQL-like quotes

// - UTF-8 version of the function available in SysUtils

// - this function implements what is specified in the official SQLite3

// documentation: "A string constant is formed by enclosing the string in single

// quotes ('). A single quote within the string can be encoded by putting two

// single quotes in a row - as in Pascal."

function QuotedStr(const S: RawUTF8; Quote: AnsiChar=''''): RawUTF8; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// format a buffered text content with SQL-like quotes

// - this function implements what is specified in the official SQLite3

// documentation: "A string constant is formed by enclosing the string in single

// quotes ('). A single quote within the string can be encoded by putting two

// single quotes in a row - as in Pascal."

function QuotedStr(Text: PUTF8Char; Quote: AnsiChar): RawUTF8; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// format a buffered text content with SQL-like quotes

// - this function implements what is specified in the official SQLite3

// documentation: "A string constant is formed by enclosing the string in single

// quotes ('). A single quote within the string can be encoded by putting two

// single quotes in a row - as in Pascal."

procedure QuotedStr(Text: PUTF8Char; Quote: AnsiChar; var result: RawUTF8); overload;



/// convert a buffered text content into a JSON string

// - with proper escaping of the content, and surounding " characters

procedure QuotedStrJSON(const aText: RawUTF8; var result: RawUTF8);



/// unquote a SQL-compatible string

// - the first character in P^ must be either ', either " then double quotes

// are transformed into single quotes

// - 'text '' end'   -> text ' end

// - "text "" end"   -> text " end

// - returns nil if P doesn't contain a valid SQL string

// - returns a pointer just after the quoted text otherwise

function UnQuoteSQLStringVar(P: PUTF8Char; out Value: RawUTF8): PUTF8Char;



/// unquote a SQL-compatible string

function UnQuoteSQLString(const Value: RawUTF8): RawUTF8;



/// unquote a SQL-compatible symbol name

// - e.g. '[symbol]' -> 'symbol' or '"symbol"' -> 'symbol'

function UnQuotedSQLSymbolName(const ExternalDBSymbol: RawUTF8): RawUTF8;



/// get the next character after a quoted buffer

// - the first character in P^ must be either ', either "

// - it will return the latest quote position, ignoring double quotes within

function GotoEndOfQuotedString(P: PUTF8Char): PUTF8Char;

  {$ifdef HASINLINE}inline;{$endif}



/// get the next character after a quoted buffer

// - the first character in P^ must be "

// - it will return the latest " position, ignoring \" within

function GotoEndOfJSONString(P: PUTF8Char): PUTF8Char;

  {$ifdef HASINLINE}inline;{$endif}



/// get the next character not in [#1..' ']

function GotoNextNotSpace(P: PUTF8Char): PUTF8Char;

  {$ifdef HASINLINE}inline;{$endif}



/// 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;



/// return line begin from source array of chars, and go to next line

// - next will contain the beginning of next line, or nil if source if ended

function GetNextLineBegin(source: PUTF8Char; out next: PUTF8Char): PUTF8Char;

  {$ifdef HASINLINE}inline;{$endif}



/// compute the line length from source array of chars

// - end counting at either #0, #13 or #10

function GetLineSize(P,PEnd: PUTF8Char): PtrUInt;



/// returns true if the line length from source array of chars is not less than

// the specified count

function GetLineSizeSmallerThan(P,PEnd: PUTF8Char; aMinimalCount: integer): boolean;



/// return next CSV string from P, nil if no more

function GetNextItem(var P: PUTF8Char; Sep: AnsiChar= ','): 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= ',');



/// return next CSV string as unsigned integer from P, 0 if no more

function GetNextItemCardinal(var P: PUTF8Char; Sep: AnsiChar= ','): PtrUInt;



/// return next CSV string as signed integer from P, 0 if no more

function GetNextItemInteger(var P: PUTF8Char; Sep: AnsiChar= ','): PtrInt;



/// return next CSV string as 64 bit signed integer from P, 0 if no more

function GetNextItemInt64(var P: PUTF8Char; Sep: AnsiChar= ','): Int64;



/// 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

function GetNextItemDouble(var P: PUTF8Char; Sep: AnsiChar= ','): double;



/// return n-th indexed CSV string in P, starting at Index=0 for first one

function GetCSVItem(P: PUTF8Char; Index: PtrUInt; Sep: AnsiChar = ','): RawUTF8;



/// 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=','); 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;



/// quick helper to initialize a dynamic array of RawUTF8 from some constants

// - can be used e.g. as:

// ! MyArray := TRawUTF8DynArrayFrom(['a','b','c']);

function TRawUTF8DynArrayFrom(const Values: array of RawUTF8): TRawUTF8DynArray;



/// append one or several values to a local "array of const" variable

procedure AddArrayOfConst(var Dest: TTVarRecDynArray; const Values: array of const);



/// return the index of Value in Values[], -1 if not found

function FindRawUTF8(const Values: TRawUTF8DynArray; const Value: RawUTF8;

  CaseSensitive: boolean=true): integer; overload;



/// return the index of Value in Values[], -1 if not found

// - can optionally call IdemPropNameU() for property matching

function FindRawUTF8(const Values: TRawUTF8DynArray; ValuesCount: integer;

  const Value: RawUTF8; SearchPropName: boolean): integer; overload;



/// return the index of Value in Values[], -1 if not found

function FindRawUTF8(const Values: array of RawUTF8; const Value: RawUTF8;

  CaseSensitive: boolean=true): integer; overload;



/// return the index of Value in Values[], -1 if not found

// - here name search would use fast IdemPropNameU() function

function FindPropName(const Names: array of RawUTF8; const Name: RawUTF8): integer; 



/// true if Value was added successfully in Values[]

function AddRawUTF8(var Values: TRawUTF8DynArray; const Value: RawUTF8;

  NoDuplicates: boolean=false; CaseSensitive: boolean=true): boolean; overload;



/// add the Value to Values[], with an external count variable, for performance

procedure AddRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer;

  const Value: RawUTF8); overload;



type

  /// simple stack-allocated type for handling a type names list

  TPropNameList = {$ifndef UNICODE}object{$else}record{$endif}

    Values: TRawUTF8DynArray;

    Count: Integer;

    /// initialize the list

    // - set Count := 0

    procedure Init;

    /// search for a Value within Values[0..Count-1] using IdemPropNameU()

    function FindPropName(const Value: RawUTF8): Integer;

    /// if Value is in Values[0..Count-1] using IdemPropNameU() returns FALSE

    // - otherwise, returns TRUE and add Value to Values[]

    function AddPropName(const Value: RawUTF8): Boolean;

  end;



/// true if both TRawUTF8DynArray are the same

// - comparison is case-sensitive

function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray): boolean;



/// convert the string dynamic array into a dynamic array of UTF-8 strings

procedure StringDynArrayToRawUTF8DynArray(const Source: TStringDynArray;

  var Result: TRawUTF8DynArray);



/// convert the string list into a dynamic array of UTF-8 strings

procedure StringListToRawUTF8DynArray(Source: TStringList; var Result: TRawUTF8DynArray);



/// find a Name= Value in a [Section] of a INI RawUTF8 Content

// - this function scans the Content memory buffer, and is

// therefore very fast (no temporary TMemIniFile is created)

// - if Section equals '', find the Name= value before any [Section]

function FindIniEntry(const Content, Section,Name: RawUTF8): RawUTF8;



/// find a Name= Value in a [Section] of a INI WinAnsi Content

// - same as FindIniEntry(), but the value is converted from WinAnsi into UTF-8

function FindWinAnsiIniEntry(const Content, Section,Name: RawUTF8): RawUTF8;



/// find a Name= numeric Value in a [Section] of a INI RawUTF8 Content and

// return it as an integer, or 0 if not found

// - this function scans the Content memory buffer, and is

// therefore very fast (no temporary TMemIniFile is created)

// - if Section equals '', find the Name= value before any [Section]

function FindIniEntryInteger(const Content, Section,Name: RawUTF8): integer;

  {$ifdef HASINLINE}inline;{$endif}



/// find a Name= Value in a [Section] of a .INI file

// - if Section equals '', find the Name= value before any [Section]

// - use internaly fast FindIniEntry() function above

function FindIniEntryFile(const FileName: TFileName; const Section,Name: RawUTF8): RawUTF8;



/// update a Name= Value in a [Section] of a INI RawUTF8 Content

// - this function scans and update the Content memory buffer, and is

// therefore very fast (no temporary TMemIniFile is created)

// - if Section equals '', update the Name= value before any [Section]

procedure UpdateIniEntry(var Content: RawUTF8; const Section,Name,Value: RawUTF8);



/// update a Name= Value in a [Section] of a .INI file

// - if Section equals '', update the Name= value before any [Section]

// - use internaly fast UpdateIniEntry() function above

procedure UpdateIniEntryFile(const FileName: TFileName; const Section,Name,Value: RawUTF8);



/// find the position of the [SEARCH] section in source

// - return true if [SEARCH] was found, and store pointer to the line after it in source

function FindSectionFirstLine(var source: PUTF8Char; search: PAnsiChar): boolean;



/// find the position of the [SEARCH] section in source

// - return true if [SEARCH] was found, and store pointer to the line after it in source

// - this version expects source^ to point to an Unicode char array

function FindSectionFirstLineW(var source: PWideChar; search: PUTF8Char): boolean;



/// retrieve the whole content of a section as a string

// - SectionFirstLine may have been obtained by FindSectionFirstLine() function above

function GetSectionContent(SectionFirstLine: PUTF8Char): RawUTF8; overload;



/// retrieve the whole content of a section as a string

// - use SectionFirstLine() then previous GetSectionContent()

function GetSectionContent(const Content, SectionName: RawUTF8): RawUTF8; overload;



/// delete a whole [Section]

// - if EraseSectionHeader is TRUE (default), then the [Section] line is also

// deleted together with its content lines

// - return TRUE if something was changed in Content

// - return FALSE if [Section] doesn't exist or is already void

function DeleteSection(var Content: RawUTF8; const SectionName: RawUTF8;

  EraseSectionHeader: boolean=true): boolean; overload;



/// delete a whole [Section]

// - if EraseSectionHeader is TRUE (default), then the [Section] line is also

// deleted together with its content lines

// - return TRUE if something was changed in Content

// - return FALSE if [Section] doesn't exist or is already void

// - SectionFirstLine may have been obtained by FindSectionFirstLine() function above

function DeleteSection(SectionFirstLine: PUTF8Char; var Content: RawUTF8;

  EraseSectionHeader: boolean=true): boolean; overload;



/// replace a whole [Section] content by a new content

// - create a new [Section] if none was existing

procedure ReplaceSection(var Content: RawUTF8; const SectionName,

  NewSectionContent: RawUTF8); overload;



/// replace a whole [Section] content by a new content

// - create a new [Section] if none was existing

// - SectionFirstLine may have been obtained by FindSectionFirstLine() function above

procedure ReplaceSection(SectionFirstLine: PUTF8Char;

  var Content: RawUTF8; const NewSectionContent: RawUTF8); overload;



/// return TRUE if Value of UpperName does exist in P, till end of current section

// - expect UpperName as 'NAME='

function ExistsIniName(P: PUTF8Char; UpperName: PAnsiChar): boolean;



/// find the Value of UpperName in P, till end of current section

// - expect UpperName as 'NAME='

function FindIniNameValue(P: PUTF8Char; UpperName: PAnsiChar): RawUTF8;



/// return TRUE if one of the Value of UpperName exists in P, till end of

// current section

// - expect UpperName e.g. as 'CONTENT-TYPE: '

// - expect UpperValues to be any upper value with left side matching, e.g. as

// used by IsHTMLContentTypeTextual() function:

// ! result := ExistsIniNameValue(htmlHeaders,HEADER_CONTENT_TYPE_UPPER,

// !  ['TEXT/','APPLICATION/JSON','APPLICATION/XML']);

// - warning: this function calls IdemPCharArray(), so expects UpperValues[]

/// items to have AT LEAST TWO CHARS (it will use fast initial 2 bytes compare)

function ExistsIniNameValue(P: PUTF8Char; const UpperName: RawUTF8;

  const UpperValues: array of PAnsiChar): boolean;



/// find the integer Value of UpperName in P, till end of current section

// - expect UpperName as 'NAME='

// - return 0 if no NAME= entry was found

function FindIniNameValueInteger(P: PUTF8Char; UpperName: PAnsiChar): integer;

  {$ifdef HASINLINE}inline;{$endif}



/// read a File content into a String

// - content can be binary or text

// - returns '' if file was not found or any read error occured

// - uses RawByteString for byte storage, whatever the codepage is

function StringFromFile(const FileName: TFileName): 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): 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;



/// 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}



/// 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

// - 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='*.*';

  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

function DirectoryDeleteOlderFiles(const Directory: TFileName; TimePeriod: TDateTime;

   const Mask: TFileName='*.*'; Recursive: Boolean=false): Boolean;



/// creates a directory if not already existing

// - returns the full expanded directory name, including trailing backslash

function EnsureDirectoryExists(const Directory: TFileName;

  RaiseExceptionOnCreationFailure: boolean=false): TFileName;



type

  {$A-}

  /// file found result item, as returned by FindFiles()

  TFindFiles = {$ifndef UNICODE}object{$else}record{$endif}

    /// 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);

  end;

  {$A+}

  /// result list, as returned by FindFiles()

  TFindFilesDynArray = array of TFindFiles;



/// search for matching file names

// - just a wrapper around FindFirst/FindNext

// - you may specify several masks in Mask, e.g. as '*.htm;*.html'

function FindFiles(const Directory,Mask: TFileName;

  const IgnoreFileName: TFileName=''; SortByName: boolean=false;

  IncludesDir: boolean=true): TFindFilesDynArray;



{$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;



/// 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}



/// extract file name, without its extension

function GetFileNameWithoutExt(const FileName: TFileName): TFileName;



/// extract a file extension from a file name, then compare with a comma

// separated list of extensions

// - e.g. GetFileNameExtIndex('test.log','exe,log,map')=1

// - will return -1 if no file extension match

// - will return any matching extension, starting count at 0

// - extension match is case-insensitive

function GetFileNameExtIndex(const FileName, CSVExt: TFileName): integer;



/// copy one file to another, similar to the Windows API

function CopyFile(const Source, Target: TFileName; FailIfExists: boolean): boolean;



/// copy the date of one file to another

function FileSetDateFrom(const Dest: TFileName; SourceHandle: integer): boolean;



/// retrieve a property value in a text-encoded class

// - follows the Delphi serialized text object format, not standard .ini

// - if the property is a string, the simple quotes ' are trimed

function FindObjectEntry(const Content, Name: RawUTF8): RawUTF8;



/// retrieve a filename property value in a text-encoded class

// - follows the Delphi serialized text object format, not standard .ini

// - if the property is a string, the simple quotes ' are trimed

// - any file path and any extension are trimmed

function FindObjectEntryWithoutExt(const Content, Name: RawUTF8): RawUTF8;





type

  /// available pronunciations for our fast Soundex implementation

  TSynSoundExPronunciation =

    (sndxEnglish, sndxFrench, sndxSpanish, sndxNone);



  TSoundExValues = array[0..ord('Z')-ord('B')] of byte;

  PSoundExValues = ^TSoundExValues;



  PSynSoundEx = ^TSynSoundEx;

  /// fast search of a text value, using the Soundex approximation mechanism

  // - Soundex is a phonetic algorithm for indexing names by sound,

  //  as pronounced in a given language. The goal is for homophones to be

  //  encoded to the same representation so that they can be matched despite

  //  minor differences in spelling

  // - this implementation is very fast and can be used e.g. to parse and search

  //  in a huge text buffer

  // - This version also handles french and spanish pronunciations on request,

  //  which differs from default Soundex, i.e. English

  TSynSoundEx = {$ifndef UNICODE}object{$else}record{$endif}

  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;

    /// 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;



/// Retrieve the Soundex value of a text word, from UTF-8 buffer

// - Return the soundex value as an easy to use cardinal value, 0 if the

// incoming string contains no valid word

// - if next is defined, its value is set to the end of the encoded word

// (so that you can call again this function to encode a full sentence)

// - very fast: all UTF-8 decoding is handled on the fly

function SoundExUTF8(U: PUTF8Char; next: PPUTF8Char=nil;

  Lang: TSynSoundExPronunciation=sndxEnglish): cardinal;



const

  /// number of bits to use for each interresting soundex char

  // - default is to use 8 bits, i.e. 4 soundex chars, which is the

  // standard approach

  // - for a more detailled soundex, use 4 bits resolution, which will

  // compute up to 7 soundex chars in a cardinal (that's our choice)

  SOUNDEX_BITS = 4;



/// return true if UpperValue (Ansi) is contained in A^ (Ansi)

// - find UpperValue starting at word beginning, not inside words

function FindAnsi(A, UpperValue: PAnsiChar): boolean;



/// return true if UpperValue (Ansi) is contained in U^ (UTF-8 encoded)

// - find UpperValue starting at word beginning, not inside words

// - UTF-8 decoding is done on the fly (no temporary decoding buffer is used)

function FindUTF8(U: PUTF8Char; UpperValue: PAnsiChar): boolean;



/// return true if Upper (Unicode encoded) is contained in U^ (UTF-8 encoded)

// - will use the slow but accurate Operating System API to perform the

// comparison at Unicode-level

function FindUnicode(PW: PWideChar; Upper: PWideChar; UpperLen: integer): boolean;



/// trim first lowercase chars ('otDone' will return 'Done' e.g.)

// - return a PUTF8Char to avoid any memory allocation

function TrimLeftLowerCase(const V: RawUTF8): PUTF8Char;



/// trim first lowercase chars ('otDone' will return 'Done' e.g.)

// - return an RawUTF8 string: enumeration names are pure 7bit ANSI with Delphi 7

// to 2007, and UTF-8 encoded with Delphi 2009+

function TrimLeftLowerCaseShort(V: PShortString): RawUTF8;



/// trim first lowercase chars ('otDone' will return 'Done' e.g.)

// - return a shortstring: enumeration names are pure 7bit ANSI with Delphi 7

// to 2007, and UTF-8 encoded with Delphi 2009+

function TrimLeftLowerCaseToShort(V: PShortString): ShortString;





/// 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;



/// 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;



/// UnCamelCase and translate the enumeration item

function GetCaptionFromEnum(aTypeInfo: pointer; aIndex: integer): string;



{$ifdef LINUX}

const

  ANSI_CHARSET = 0;

  DEFAULT_CHARSET = 1;

  SYMBOL_CHARSET = 2;

  SHIFTJIS_CHARSET = $80;

  HANGEUL_CHARSET = 129;

  GB2312_CHARSET = 134;

  CHINESEBIG5_CHARSET = 136;

  OEM_CHARSET = 255;

  JOHAB_CHARSET = 130;

  HEBREW_CHARSET = 177;

  ARABIC_CHARSET = 178;

  GREEK_CHARSET = 161;

  TURKISH_CHARSET = 162;

  VIETNAMESE_CHARSET = 163;

  THAI_CHARSET = 222;

  EASTEUROPE_CHARSET = 238;

  RUSSIAN_CHARSET = 204;

  BALTIC_CHARSET = 186;

{$else}

{$ifdef FPC}

const

  VIETNAMESE_CHARSET = 163;

{$endif}

{$endif}



/// convert a char set to a code page

function CharSetToCodePage(CharSet: integer): cardinal;



/// convert a code page to a char set

function CodePageToCharSet(CodePage: Cardinal): Integer;



/// retrieve the MIME content type from a supplied binary buffer

// - return the MIME type, ready to be appended to a 'Content-Type: ' HTTP header

// - returns DefaultContentType if the binary buffer has an unknown layout

function GetMimeContentTypeFromBuffer(Content: Pointer; Len: integer;

  const DefaultContentType: RawUTF8): RawUTF8;



/// retrieve the MIME content type from a supplied binary buffer or file name

// - return the MIME type, ready to be appended to a 'Content-Type: ' HTTP header

// - default is 'application/octet-stream' (BINARY_CONTENT_TYPE) or

// 'application/extension' if FileName was specified

// - see @http://en.wikipedia.org/wiki/Internet_media_type for most common values

function GetMimeContentType(Content: Pointer; Len: integer;

   const FileName: TFileName=''): RawUTF8; 



/// retrieve the HTTP header for MIME content type from a supplied binary buffer

// - just append HEADER_CONTENT_TYPE and GetMimeContentType() result

// - can be used as such:

// !  Call.OutHead := GetMimeContentTypeHeader(Call.OutBody,aFileName);

function GetMimeContentTypeHeader(const Content: RawByteString;

  const FileName: TFileName=''): RawUTF8;



/// retrieve if some content is compressed, from a supplied binary buffer

// - returns TRUE, if the header in binary buffer "may" be compressed (this method

// can trigger false positives), e.g. begin with zip/gz/gif/wma/png/jpeg markers

function IsContentCompressed(Content: Pointer; Len: integer): boolean;



/// returns TRUE if the supplied HTML Headers contains 'Content-Type: text/...',

// 'Content-Type: application/json' or 'Content-Type: application/xml'

function IsHTMLContentTypeTextual(Headers: PUTF8Char): Boolean;



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 (so will work with any PAnsiChar)

// - returns -1 if the specified Value was found (i.e. adding will duplicate a value)

function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt; overload;



/// 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)

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 (so will work with any PAnsiChar)

// - returns -1 if the specified Value was not found

function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): 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 (so will work with any PAnsiChar)

// - returns -1 if the specified Value was not found

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

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 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;



/// 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 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 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 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 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 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;



/// 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 PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif}

  

/// fast search of an unsigned Word value position in a Word array

// - Count is the number of Word entries in P^

// - return index of P^[index]=Value

// - return -1 if Value was not found

function WordScanIndex(P: PWordArray; Count: PtrInt; Value: word): integer;

  {$ifdef HASINLINE}inline;{$endif}



/// sort an Integer array, low values first

procedure QuickSortInteger(ID: PIntegerArray; L, R: PtrInt); overload;



/// sort an Integer array, low values first

procedure QuickSortInteger(ID,CoValues: PIntegerArray; L, R: PtrInt); overload;



/// sort an Integer array, low values first

procedure QuickSortInteger(var ID: TIntegerDynArray); overload;



/// sort a 64 bit Integer array, low values first

procedure QuickSortInt64(ID: PInt64Array; L, R: PtrInt); overload;



/// sort a 64 bit Integer array, low values first

procedure QuickSortInt64(ID,CoValues: PInt64Array; L, R: PtrInt); overload;



/// 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 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 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;



/// fast binary search of a 64 bit 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;



/// sort a PtrInt array, low values first

procedure QuickSortPtrInt(P: PPtrIntArray; L, R: PtrInt);

  {$ifdef HASINLINE}inline;{$endif}



/// fast 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 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;



/// 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 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 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 64-bit integer value at the end of a dynamic array of integers

procedure AddInt64(var Values: TInt64DynArray; var ValuesCount: integer; Value: Int64); overload;

  {$ifdef HASINLINE}inline;{$endif}



/// add a 64-bit integer value at the end of a dynamic array of integers

procedure AddInt64(var Values: TInt64DynArray; Value: Int64); overload;

  {$ifdef HASINLINE}inline;{$endif}



/// 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 64-bit integer in Values[]

procedure DeleteInt64(var Values: TInt64DynArray; Index: PtrInt); overload;



/// find the maximum 32-bit integer in Values[]

function MaxInteger(const Values: TIntegerDynArray; ValuesCount: integer;

  MaxStart: integer=-1): Integer;



/// fill already allocated Reversed[] so that Reversed[Values[i]]=i

procedure Reverse(const Values: TIntegerDynArray; ValuesCount: integer;

  Reversed: PIntegerArray);



/// fill some values with i,i+1,i+2...i+Count-1

procedure FillIncreasing(Values: PIntegerArray; StartValue, Count: integer);



/// copy some Int64 values into an unsigned integer array

procedure Int64ToUInt32(Values64: PInt64Array; Values32: PCardinalArray; Count: integer);



/// add the strings in the specified CSV text into a dynamic array of integer

procedure CSVToIntegerDynArray(CSV: PUTF8Char; var Result: TIntegerDynArray);



/// add the strings in the specified CSV text into a dynamic array of integer

procedure CSVToInt64DynArray(CSV: PUTF8Char; var Result: TInt64DynArray);



/// 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: array of integer; ValuesCount: integer;

  const Prefix: RawUTF8=''; const Suffix: RawUTF8=''): RawUTF8;



/// 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: array of Int64; ValuesCount: integer;

  const Prefix: RawUTF8=''; const Suffix: RawUTF8=''): RawUTF8;



/// quick helper to initialize a dynamic array of integer from some constants

// - can be used e.g. as:

// ! MyArray := TIntegerDynArrayFrom([1,2,3]);

function TIntegerDynArrayFrom(const Values: array of integer): TIntegerDynArray; 



/// quick helper to initialize a dynamic array of integer from 64-bit integers

// - would 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

function TInt64DynArrayFrom(const Values: TIntegerDynArray): TInt64DynArray;



type

  /// used to store and retrieve Words in a sorted array

  // - is defined either as an object either as a record, due to a bug

  // in Delphi 2009/2010 compiler (at least): this structure is not initialized

  // if defined as an object on the stack, but will be as a record :(

  TSortedWordArray = {$ifndef UNICODE}object{$else}record{$endif}

  public

    Values: TWordDynArray;

    Count: integer;

    /// add a value into the sorted array

    // - return the index of the new inserted value into the Values[] array

    // - return -(foundindex+1) if this value is already in the Values[] array

    function Add(aValue: Word): PtrInt;

    /// return the index if the supplied value in the Values[] array

    // - return -1 if not found

    function IndexOf(aValue: Word): PtrInt; {$ifdef HASINLINE}inline;{$endif}

  end;



/// convert a cardinal into a 32-bit variable-length integer buffer

function ToVarUInt32(Value: PtrUInt; Dest: PByte): PByte;



/// return the number of bytes necessary to store a 32-bit variable-length integer

// - i.e. the ToVarUInt32() buffer size

function ToVarUInt32Length(Value: PtrUInt): PtrUInt;

  {$ifdef HASINLINE}inline;{$endif}



/// return the number of bytes necessary to store some data with a its

// 32-bit variable-length integer legnth

function ToVarUInt32LengthWithData(Value: PtrUInt): PtrUInt;

  {$ifdef HASINLINE}inline;{$endif}



/// convert an integer into a 32-bit variable-length integer buffer

// - store negative values as cardinal two-complement, i.e.

// 0=0,1=1,2=-1,3=2,4=-2...

function ToVarInt32(Value: PtrInt; Dest: PByte): PByte;



/// convert a 32-bit variable-length integer buffer into a cardinal

function FromVarUInt32(var Source: PByte): cardinal;

  {$ifdef HASINLINE}inline;{$endif}



/// convert a 32-bit variable-length integer buffer into a cardinal

// - this version must be called if Source^ has already been checked to be > $7f

// ! result := Source^;

// ! inc(Source);

// ! if result>$7f then

// !   result := (result and $7F) or FromVarUInt32Up128(Source);

function FromVarUInt32Up128(var Source: PByte): cardinal;



/// convert a 32-bit variable-length integer buffer into a cardinal

// - this version must be called if Source^ has already been checked to be > $7f

function FromVarUInt32High(var Source: PByte): cardinal;



/// convert a 32-bit variable-length integer buffer into an integer

// - decode negative values from cardinal two-complement, i.e.

// 0=0,1=1,2=-1,3=2,4=-2...

function FromVarInt32(var Source: PByte): integer; {$ifdef HASINLINE}inline;{$endif}



/// convert a UInt64 into a 64-bit variable-length integer buffer

function ToVarUInt64(Value: QWord; Dest: PByte): PByte;



/// convert a 64-bit variable-length integer buffer into a UInt64

function FromVarUInt64(var Source: PByte): QWord;



/// convert a Int64 into a 64-bit variable-length integer buffer

function ToVarInt64(Value: Int64; Dest: PByte): PByte; {$ifdef HASINLINE}inline;{$endif}



/// convert a 64-bit variable-length integer buffer into a Int64

function FromVarInt64(var Source: PByte): Int64;



/// convert a 64-bit variable-length integer buffer into a Int64

// - this version won't update the Source pointer

function FromVarInt64Value(Source: PByte): Int64;



/// jump a value in the 32-bit or 64-bit variable-length integer buffer

function GotoNextVarInt(Source: PByte): pointer; {$ifdef HASINLINE}inline;{$endif}



/// convert a RawUTF8 into an UTF-8 encoded variable-length buffer

function ToVarString(const Value: RawUTF8; Dest: PByte): PByte;



/// jump a value in variable-length text buffer

function GotoNextVarString(Source: PByte): pointer; {$ifdef HASINLINE}inline;{$endif}



/// retrieve a variable-length UTF-8 encoded text buffer in a newly allocation RawUTF8

function FromVarString(var Source: PByte): RawUTF8; overload;



/// retrieve a variable-length text buffer

// - this overloaded function will set the supplied code page to the AnsiString

procedure FromVarString(var Source: PByte; var Value: RawByteString;

  CodePage: integer); overload;



/// retrieve a variable-length UTF-8 encoded text buffer in a temporary buffer

// - caller should call Value.Done after use of the Value.buf memory

// - this overloaded function would include a trailing #0, so Value.buf could

// be parsed as a valid PUTF8Char buffer (e.g. containing JSON)

procedure FromVarString(var Source: PByte; var Value: TSynTempBuffer); overload;



type

  /// kind of result returned by FromVarBlob() function

  TValueResult = record

    /// start of data value

    Ptr: PAnsiChar;

    /// value length (in bytes)

    Len: integer;

  end;



/// retrieve pointer and length to a variable-length text/blob buffer

function FromVarBlob(Data: PByte): TValueResult; {$ifdef HASINLINE}inline;{$endif}







{ ************ low-level RTTI types and conversion routines ***************** }



type

  /// function prototype to be used for TDynArray Sort and Find method

  // - common functions exist for base types: see e.g. SortDynArrayByte,

  // SortDynArrayWord, SortDynArrayInteger, SortDynArrayCardinal,

  // SordDynArraySingle, SortDynArrayInt64, SortDynArrayBoolean,

  // 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 A<B, 1 if A>B

  TDynArraySortCompare = function(const A,B): integer;



  /// event oriented version of TDynArraySortCompare

  TEventDynArraySortCompare = function(const A,B): integer 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 .. djSynUnicode 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, djDouble, djCurrency,

    djTimeLog, djDateTime, djRawUTF8, djWinAnsi, djString, djRawByteString,

    djWideString, djSynUnicode, djInterface,

    {$ifndef NOVARIANTS}djVariant,{$endif}

    djCustom);



  /// internal set to specify some standard Delphi arrays

  TDynArrayKinds = set of TDynArrayKind;



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

  /// a wrapper around a dynamic array with one dimension

  // - provide TList-like methods using fast RTTI information

  // - can be used to fast save/retrieve all memory content to a TStream

  // - note that the "const Elem" is not checked at compile time nor runtime:

  // you must ensure that Elem matchs the element type of the dynamic array

  // - can use external Count storage to make Add() and Delete() much faster

  // (avoid most reallocation of the memory buffer)

  // - Note that TDynArray is just a wrapper around an existing dynamic array:

  // methods can modify the content of the associated variable but the TDynArray

  // doesn't contain any data by itself. It is therefore aimed to initialize

  // a TDynArray wrapper on need, to access any existing dynamic array.

  // - is defined either as an object either as a record, due to a bug

  // in Delphi 2009/2010 compiler (at least): this structure is not initialized

  // if defined as an object on the stack, but will be as a record :(

  {$ifdef UNDIRECTDYNARRAY}

  TDynArray = record

  private

  {$else}

  TDynArray = object

  protected

  {$endif}

    fValue: PPointer;

    fTypeInfo: pointer;

    fElemSize: PtrUInt;

    fElemType: pointer;

    fCountP: PInteger;

    fCompare: TDynArraySortCompare;

    fKnownSize: integer;

    fSorted: boolean;

    fKnownType: TDynArrayKind;

    fIsObjArray: (oaUnknown, oaTrue, oaFalse);

    function GetCount: integer; {$ifdef HASINLINE}inline;{$endif}

    procedure SetCount(aCount: integer);

    function GetCapacity: integer;

    procedure SetCapacity(aCapacity: integer);

    procedure SetCompare(const aCompare: TDynArraySortCompare); {$ifdef HASINLINE}inline;{$endif}

    function FindIndex(const Elem; aIndex: PIntegerDynArray;

      aCompare: TDynArraySortCompare): integer;

    function GetArrayTypeName: RawUTF8;

    function GetIsObjArray: boolean; {$ifdef HASINLINE}inline;{$endif}

    procedure SetIsObjArray(aValue: boolean); {$ifdef HASINLINE}inline;{$endif}

    /// will set fKnownType and fKnownOffset/fKnownSize fields

    function ToKnownType(exactType: boolean=false): TDynArrayKind;

    /// faster than System.DynArraySetLength() function + handle T*ObjArray

    procedure InternalSetLength(NewLength: PtrUInt);

  public

    /// initialize the wrapper with a one-dimension dynamic array

    // - the dynamic array must have been defined with its own type

    // (e.g. TIntegerDynArray = array of Integer)

    // - if aCountPointer is set, it will be used instead of length() to store

    // the dynamic array items count - it will be much faster when adding

    // elements to the array, because the dynamic array won't need to be

    // resized each time - but in this case, you should use the Count property

    // instead of length(array) or high(array) when accessing the data: in fact

    // length(array) will store the memory size reserved, not the items count

    // - if aCountPointer is set, its content will be set to 0, whatever the

    // array length is, or the current aCountPointer^ value is

    // - a sample usage may be:

    // !var DA: TDynArray;

    // !    A: TIntegerDynArray;

    // !begin

    // !  DA.Init(TypeInfo(TIntegerDynArray),A);

    // ! (...)

    // - a sample usage may be (using a count variable):

    // !var DA: TDynArray;

    // !    A: TIntegerDynArray;

    // !    ACount: integer;

    // !    i: integer;

    // !begin

    // !  DA.Init(TypeInfo(TIntegerDynArray),A,@ACount);

    // !  for i := 1 to 100000 do

    // !    DA.Add(i); // MUCH faster using the ACount variable

    // ! (...)   // now you should use DA.Count or Count instead of length(A)

    procedure Init(aTypeInfo: pointer; var aValue; aCountPointer: PInteger=nil);

    /// initialize the wrapper with a one-dimension dynamic array

    // - this version accepts to specify how comparison should occur, using

    // TDynArrayKind  kind of first field

    // - djNone and djCustom are too vague, and would 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..djSynUnicode 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}

    /// 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

    // will be a bit slower than e.g. with a TList: the list is reallocated

    // every time a record is added - but in practice, with FastMM4 or

    // SynScaleMM, there is no big speed penalty - for even better speed, you

    // can also specify an external count variable in Init(...,@Count) method

    function Add(const Elem): integer;

    /// add an element to the dynamic array

    // - this version add a void element to the array, and returns its index

    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: Integer; const Elem);

    /// delete the whole dynamic array content

    // - this method will recognize T*ObjArray types and free all instances

    procedure Clear;

      {$ifdef HASINLINE}inline;{$endif}

    /// delete one item inside the dynamic array

    // - the deleted element is finalized if necessary

    // - this method will recognize T*ObjArray types and free all instances

    procedure Delete(aIndex: Integer);

    /// 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)

    function ElemPtr(aIndex: integer): pointer;

    /// 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): integer;

    /// 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 binary search

    // - if the array is not sorted, it will use slower 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): integer; 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 binary search

    // - if an indexed lookup is not supplied (i.e aIndex=nil),

    // this function will use slower but accurate 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): integer; 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 binary search

    // - if the array is not sorted, it will use slower 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 binary search

    // - if the array is not sorted, it will use slower 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 binary search

    // - if the array is not sorted, it will use slower 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 binary search

    // - if the array is not sorted, it will use slower 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);

    /// 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);

    /// 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

    // - 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

    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

    // - this method will raise an ESynException for T*ObjArray types

    function SaveTo(Dest: PAnsiChar): PAnsiChar; overload;

    /// compute the number of bytes needed to save a dynamic array content

    // - this method will raise an ESynException for T*ObjArray types

    function SaveToLength: integer;

    /// save the dynamic array content into a RawByteString

    // - this method will raise an ESynException for T*ObjArray types

    function SaveTo: RawByteString; overload;

    /// load the dynamic array content from a memory buffer

    // - return nil if the Source buffer is incorrect (invalid type or internal

    // checksum e.g.)

    // - in case of success, return the memory buffer pointer just after the

    // read content

    // - this method will raise an ESynException for T*ObjArray types

    // - return a pointer at the end of the data read from Source, nil on error

    function LoadFrom(Source: PAnsiChar): PAnsiChar;

    /// serialize the dynamic array content as JSON

    // - is just a wrapper around TTextWriter.AddDynArrayJSON()

    // - this method will therefore recognize T*ObjArray types

    function SaveToJSON(EnumSetsAsText: boolean=false): RawUTF8;

    /// load the dynamic array content from an UTF-8 encoded JSON buffer

    // - expect the format as saved by TTextWriter.AddDynArrayJSON method, i.e.

    // handling TBooleanDynArray, TIntegerDynArray, TInt64DynArray, TCardinalDynArray,

    // TDoubleDynArray, TCurrencyDynArray, TWordDynArray, TByteDynArray,

    // TRawUTF8DynArray, TWinAnsiDynArray, TRawByteStringDynArray,

    // TStringDynArray, TWideStringDynArray, TSynUnicodeDynArray,

    // TTimeLogDynArray and TDateTimeDynArray as JSON array - or any customized

    // valid JSON serialization as set by TTextWriter.RegisterCustomJSONSerializer

    // - or any other kind of array as Base64 encoded binary stream precessed

    // via JSON_BASE64_MAGIC (UTF-8 encoded \uFFF0 special code)

    // - typical handled content could be

    // ! '[1,2,3,4]' or '["\uFFF0base64encodedbinary"]'

    // - return a pointer at the end of the data read from P, nil in case

    // of an invalid input buffer

    // - this method will recognize T*ObjArray types, and will first free

    // any existing instance before unserializing, to avoid memory leak

    // - warning: the content of P^ will be modified during parsing: please

    // make a local copy if it will be needed later (using e.g. TSynTempBufer)

    function LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char=nil): PUTF8Char;

    ///  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)

    procedure AddArray(const DynArrayVar; aStartIndex: integer=0; aCount: integer=-1);

    {$ifndef DELPHI5OROLDER}

    /// 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 first using any supplied Compare property,

    // then by content using the RTTI element description of the whole record

    // - warning: this method won't compare T*ObjArray kind of arrays

    function Equals(const B: TDynArray): boolean;

    /// set all content of one dynamic array to the current array

    // - both must be of the same exact type

    procedure Copy(const Source: TDynArray);

    /// set all content of one dynamic array to the current array

    // - both must be of the same exact type

    procedure CopyFrom(const Source; MaxElem: integer);

    {$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);

    /// save an array element into a serialized buffer

    // - 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 Find(i+10) e.g.)

    function ElemSave(const Elem): RawByteString;

    /// load an array element as saved by the ElemSave method

    // - 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.)

    procedure ElemLoad(Source: PAnsiChar; var Elem); overload;

    /// load an array element as saved by the ElemSave method

    // - this overloaded method will retrieve the element as a memory buffer

    // and caller MUST call ElemLoadClear() method to finalize its content

    function ElemLoad(Source: PAnsiChar): RawByteString; overload;

    /// release memory allocated by ElemLoad(): RawByteString

    procedure ElemLoadClear(var ElemLoaded: RawByteString);

    /// search for an array element as saved by the ElemSave method

    // - same as ElemLoad() + Find()/IndexOf() + ElemLoadClear()

    // - will call Find() method if Compare property is set

    // - will call generic IndexOf() method if no Compare property is set

    function ElemLoadFind(Source: PAnsiChar): integer;



    /// retrieve or set the number of elements of the dynamic array

    // - same as length(DynArray) or SetLenght(DynArray)

    // - this property will recognize T*ObjArray types, so will free any stored

    // instance if the array is sized down

    property Count: integer read GetCount write SetCount;

    /// the internal buffer capacity

    // - if no external Count pointer was set with Init, is the same as Count

    // - if an external Count pointer is set, you can set a value to this

    // property before a massive use of the Add() method e.g.

    // - if no external Count pointer is set, set a value to this property

    // will affect the Count value, i.e. Add() will append after this count

    // - this property will recognize T*ObjArray types, so will free any stored

    // instance if the array is sized down

    property Capacity: integer read GetCapacity write SetCapacity;

    /// the compare function to be used for Sort and Find methods

    // - by default, no comparison function is set

    // - common functions exist for base types: e.g. SortDynArrayByte, SortDynArrayBoolean,

    // SortDynArrayWord, SortDynArrayInteger, SortDynArrayCardinal, SortDynArraySingle,

    // SortDynArrayInt64, SortDynArrayDouble, SortDynArrayAnsiString,

    // SortDynArrayAnsiStringI, SortDynArrayString, SortDynArrayStringI,

    // SortDynArrayUnicodeString, SortDynArrayUnicodeStringI

    property Compare: TDynArraySortCompare read fCompare write SetCompare;

    /// must be TRUE if the array is currently in sorted order according to

    // the compare function

    // - Add/Delete/Insert/Load* methods will reset this property to false

    // - Sort method will set this property to true

    // - you MUST set this property to false if you modify the dynamic array

    // content in your code, so that Find() won't try to use binary search in

    // an usorted array, and miss its purpose

    property Sorted: boolean read fSorted write fSorted;

    /// low-level direct access to the storage variable

    property Value: PPointer read fValue;

    /// the known type, possibly retrieved from dynamic array RTTI

    property KnownType: TDynArrayKind read fKnownType;

    /// the known RTTI information of the whole array

    property ArrayType: pointer read fTypeInfo;

    /// the known type name of the whole array

    property ArrayTypeName: RawUTF8 read GetArrayTypeName;

    /// the internal in-memory size of one element, as retrieved from RTTI

    property ElemSize: PtrUInt 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;



  /// function prototype to be used for hashing of an element

  // - it must return a cardinal hash, with as less collision as possible

  // - a good candidate is our crc32() function in optimized asm in SynZip unit

  // - TDynArrayHashed.Init will use crc32c() if no custom function is supplied,

  // which will run either as software or SSE4.2 hardware

  THasher = function(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;



  /// 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

  TOnDynArrayHashOne = function(const Elem): cardinal of object;



  /// internal structure used to store one item hash

  // - used e.g. by TDynArrayHashed or TObjectHash via TSynHashDynArray

  TSynHash = record

    /// unsigned integer hash of the item

    Hash: cardinal;

    /// index of the item in the main storage array

    Index: cardinal;

  end;



  /// internal structure used to store hashs of items

  // - used e.g. by TDynArrayHashed or TObjectHash

  TSynHashDynArray = array of TSynHash;



  {.$define DYNARRAYHASHCOLLISIONCOUNT}



  /// used to access any dynamic arrray elements using fast hash

  // - by default, binary sort could be used for searching items for TDynArray:

  // using a hash is faster on huge arrays for implementing a dictionary

  // - in this current implementation, modification (update or delete) of an

  // element is not handled yet: you should rehash all content - only

  // TDynArrayHashed.FindHashedForAdding / FindHashedAndUpdate /

  // FindHashedAndDelete will refresh the internal hash

  // - this object extends the TDynArray type, since presence of Hashs[] dynamic

  // array will increase code size if using TDynArrayHashed instead of TDynArray

  // - in order to have the better performance, you should use an external Count

  // variable, AND set the Capacity property to the expected maximum count (this

  // will avoid most ReHash calls for FindHashedForAdding+FindHashedAndUpdate)

  {$ifdef UNDIRECTDYNARRAY}

  TDynArrayHashed = record

  // pseudo inheritance for most used methods

  private

    procedure SetCount(aCount: Integer);        inline;

    procedure SetCapacity(aCapacity: Integer);  inline;

    function GetCapacity: Integer;              inline;

  public

    InternalDynArray: TDynArray;

    function Count: Integer;            inline;

    function fValue: PPointer;          inline;

    function ElemSize: PtrUInt;         inline;

    function ElemType: Pointer;         inline;

    function KnownType: TDynArrayKind;  inline;

    procedure Clear;                    inline;

    procedure ElemCopy(const A; var B); inline;

    // warning: you shall call ReHash() after manual Add/Delete

    function Add(const Elem): integer;  inline;

    procedure Delete(aIndex: Integer);  inline;

    function SaveTo: RawByteString; overload; inline;

    function SaveTo(Dest: PAnsiChar): PAnsiChar; overload; inline;

    function SaveToJSON(EnumSetsAsText: boolean=false): RawUTF8; inline;

    function LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char=nil): PUTF8Char; inline;

    function SaveToLength: integer; inline;

    function LoadFrom(Source: PAnsiChar): PAnsiChar;  inline;

    property Capacity: integer read GetCapacity write SetCapacity;

  private

  {$else UNDIRECTDYNARRAY}

  TDynArrayHashed = object(TDynArray)

  protected

  {$endif UNDIRECTDYNARRAY}

    fHashElement: TDynArrayHashOne;

    fHasher: THasher;

    fHashs: TSynHashDynArray;

    fHashsCount: integer;

    fEventCompare: TEventDynArraySortCompare;

    fHashCountTrigger: integer;

    fHashFindCount: integer;

    {$ifdef DYNARRAYHASHCOLLISIONCOUNT}

    fHashFindCollisions: cardinal;

    {$endif}

    procedure HashAdd(const Elem; aHashCode: Cardinal; var result: integer);

    /// low-level search of an element from its pre-computed hash

    // - you should NOT use this method, but rather high-level FindHashed*()

    function HashFind(aHashCode: cardinal; const Elem): integer; overload;

    /// low-level search of an element from its pre-computed hash

    // - this overloaded method will return the first matching item: use the

    // HashFind(...; const Elem) method to avoid any HashElement collision issue

    // - you should NOT use this method, but rather high-level FindHashed*()

    function HashFind(aHashCode: cardinal): integer; overload;

    function GetHashFromIndex(aIndex: Integer): Cardinal;

  public

    /// initialize the wrapper with a one-dimension dynamic array

    // - this version accepts some hash-dedicated parameters: aHashElement to

    // set how to hash each element, aCompare to handle hash collision

    // - if no aHashElement is supplied, it will hash according to the RTTI, i.e.

    // strings or binary types, and the first field for records (strings included)

    // - if no aCompare is supplied, it will use default Equals() method

    // - if no THasher function is supplied, it will use the one supplied in

    // DefaultHasher global variable, set to crc32c() by default - using

    // SSE4.2 instruction if available

    // - if CaseInsensitive is set to TRUE, it will ignore difference in 7 bit

    // alphabetic characters (e.g. compare 'a' and 'A' as equal)

    procedure Init(aTypeInfo: pointer; var aValue;

      aHashElement: TDynArrayHashOne=nil; aCompare: TDynArraySortCompare=nil;

      aHasher: THasher=nil; aCountPointer: PInteger=nil; aCaseInsensitive: boolean=false);

    /// initialize the wrapper with a one-dimension dynamic array

    // - this version accepts to specify how both hashing and comparison should

    // occur, using TDynArrayKind  kind of first field

    // - djNone and djCustom are too vague, and would 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..djSynUnicode comparison

    procedure InitSpecific(aTypeInfo: pointer; var aValue; aKind: TDynArrayKind;

      aCountPointer: PInteger=nil; aCaseInsensitive: boolean=false);

    /// will compute all hash from the current elements of the dynamic array

    // - is called within the TDynArrayHashed.Init method to initialize the

    // internal hash array

    // - can be called on purpose, when modifications have been performed on

    // the dynamic array content (e.g. in case of element deletion or update,

    // or after calling LoadFrom/Clear method) - this is not necessary after

    // FindHashedForAdding / FindHashedAndUpdate / FindHashedAndDelete methods

    function ReHash(aHasher: TOnDynArrayHashOne=nil): boolean;

    /// low-level function which would inspect the internal fHashs[] array for

    // any collision

    // - is a brute force search within fHashs[].Hash values, which may be handy

    // to validate the current HashElement() function

    // - returns -1 if no collision was found, or the index of the first collision

    function IsHashElementWithoutCollision: integer;

    /// search for an element value inside the dynamic array using hashing

    // - ELem should be of the same exact type than the dynamic array, or at

    // least matchs the fields used by both the hash function and Equals method:

    // e.g. if the searched/hashed field in a record is a string as first field,

    // you may use a string variable as Elem: other fields will be ignored

    // - returns -1 if not found, or the index in the dynamic array if found

    function FindHashed(const Elem): integer;

    /// search for an element value inside the dynamic array using hashing, and

    // fill Elem with the found content

    // - return the index found (0..Count-1), or -1 if Elem was not found

    // - warning: Elem must be of the same exact type than the dynamic array,

    // and must be a reference to a variable (you can't write Find(i+10) e.g.)

    function FindHashedAndFill(var ElemToFill): integer;

    /// search for an element value inside the dynamic array using hashing, and

    // add a void entry to the array if was not found

    // - this method will use hashing for fast retrieval

    // - Elem should be of the same exact type than the dynamic array, or at

    // least matchs the fields used by both the hash function and Equals method:

    // e.g. if the searched/hashed field in a record is a string as first field,

    // you may use a string variable as Elem: other fields will be ignored

    // - returns either the index in the dynamic array if found (and set wasAdded

    // to false), either the newly created index in the dynamic array (and set

    // wasAdded to true)

    // - for faster process (avoid ReHash), please set the Capacity property

    // - warning: in contrast to the Add() method, if an entry is added to the

    // array (wasAdded=true), the entry is left VOID: you must set the field

    // content to expecting value - in short, Elem is used only for searching,

    // not copied to the newly created entry in the array

    // - optional aHashCode parameter can be supplied with an already hashed

    // value of the item, to be used e.g. after a call to HashFind() - default

    // 0 will use fHashElement(Elem,fHasher)

    function FindHashedForAdding(const Elem; out wasAdded: boolean;

      aHashCode: cardinal=0): integer;

    /// ensure a given element name is unique, then add it to the array

    // - expected element layout is to have a RawUTF8 field at first position

    // - the aName is searched (using hashing) to be unique, and if not the case,

    // an ESynException.CreateUTF8() is raised with the supplied arguments

    // - use internaly FindHashedForAdding method

    // - this version will set the field content with the unique value

    // - returns a pointer to the newly added element (to set other fields)

    function AddUniqueName(const aName: RawUTF8;

      const ExceptionMsg: RawUTF8; const ExceptionArgs: array of const): pointer;

    /// search for a given element name, make it unique, and add it to the array

    // - expected element layout is to have a RawUTF8 field at first position

    // - the aName is searched (using hashing) to be unique, and if not the case,

    // some suffix is added to make it unique

    // - use internaly FindHashedForAdding method

    // - this version will set the field content with the unique value

    // - returns a pointer to the newly added element (to set other fields)

    function AddAndMakeUniqueName(aName: RawUTF8): pointer;

    /// search for an element value inside the dynamic array using hashing, then

    // update any matching item, or add the item if none matched

    // - if AddIfNotExisting is FALSE, returns the index found (0..Count-1),

    // or -1 if Elem was not found - update will force slow rehash all content

    // - if AddIfNotExisting is TRUE, returns the index found (0..Count-1),

    // or the index newly created/added is the Elem value was not matching -

    // add won't rehash all content - for even faster process (avoid ReHash),

    // please set the Capacity property

    // - warning: Elem must be of the same exact type than the dynamic array, and

    // must refer to a variable (you can't write FindHashedAndUpdate(i+10) e.g.)

    function FindHashedAndUpdate(const Elem; AddIfNotExisting: boolean): integer;

    /// search for an element value inside the dynamic array using hashing, and

    // delete it if matchs

    // - return the index deleted (0..Count-1), or -1 if Elem was not found

    // - this will rehash all content: this method could be slow in the current

    // implementation

    // - warning: Elem must be of the same exact type than the dynamic array, and

    // must refer to a variable (you can't write FindHashedAndDelete(i+10) e.g.)

    function FindHashedAndDelete(const Elem): integer;

    /// will search for an element value inside the dynamic array without hashing

    // - is used internally when Count < HashCountTrigger

    // - is preferred to Find(), since EventCompare would be used if defined

    // - Elem should be of the same exact type than the dynamic array, or at

    // least matchs the fields used by both the hash function and Equals method:

    // e.g. if the searched/hashed field in a record is a string as first field,

    // you may use a string variable as Elem: other fields will be ignored

    // - returns -1 if not found, or the index in the dynamic array if found

    function Scan(const Elem): integer;

    /// retrieve the hash value of a given item, from its index

    property Hash[aIndex: Integer]: Cardinal read GetHashFromIndex;

    /// alternative event-oriented Compare function to be used for Sort and Find

    // - will be used instead of Compare, to allow object-oriented callbacks

    property EventCompare: TEventDynArraySortCompare read fEventCompare write fEventCompare;

    /// custom hash function to be used for hashing of a dynamic array element

    property HashElement: TDynArrayHashOne read fHashElement;

    /// after how many items the hashing take place

    // - for smallest arrays, O(n) seach if faster than O(1) hashing, since

    // maintaining the fHashs[] lookup has some CPU and memory costs

    // - equals 32 by default 

    property HashCountTrigger: integer read fHashCountTrigger write fHashCountTrigger;

    {$ifdef DYNARRAYHASHCOLLISIONCOUNT}

    /// access to the internal collision of HashFind()

    // - it won't depend only on the HashElement(), but also on the internal

    // hash bucket size (which is much lower than 2^32 items)

    property HashFindCollisions: cardinal read fHashFindCollisions write fHashFindCollisions;

    {$endif}

  end;





  /// defines a wrapper interface around a dynamic array of TObject

  // - implemented by TObjectDynArrayWrapper for instance

  // - i.e. most common methods are available to work with a dynamic array

  // - warning: the IObjectDynArray MUST be defined in the stack, class or

  // record BEFORE the dynamic array it is wrapping, otherwise you may leak

  // memory - see for instance TSQLRestServer class:

  // ! fSessionAuthentications: IObjectDynArray; // defined before the array

  // ! fSessionAuthentication: TSQLRestServerAuthenticationDynArray;

  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;

    /// returns the number of TObject instances available

    // - note that the length of the associated dynamic array is used to store

    // the capacity of the list, so won't probably never match with this value

    function Count: integer;

    /// returns the internal array capacity of TObject instances available

    // - which is in fact the length() of the associated dynamic array

    function Capacity: integer;

  end;



  /// a wrapper to own a dynamic array of TObject

  // - this version behave list a TObjectList (i.e. owning the class instances)

  // - but the dynamic array is NOT owned by the instance

  // - will define an internal Count property, using the dynamic array length

  // as capacity: adding and deleting will be much faster

  // - implements IObjectDynArray, so that most common methods are available

  // to work with the dynamic array

  // - does not need any sub-classing of generic overhead to work, and will be

  // reference counted

  // - warning: the IObjectDynArray MUST be defined in the stack, class or

  // record BEFORE the dynamic array it is wrapping, otherwise you may leak

  // memory, and TObjectDynArrayWrapper.Destroy will raise an ESynException

  // - a sample usage may be:

  // !var DA: IObjectDynArray; // defined BEFORE the dynamic array itself

  // !    A: array of TMyObject;

  // !    i: integer;

  // !begin

  // !  DA := TObjectDynArrayWrapper.Create(A);

  // !  DA.Add(TMyObject.Create('one'));

  // !  DA.Add(TMyObject.Create('two'));

  // !  DA.Delete(0);

  // !  assert(DA.Count=1);

  // !  assert(A[0].Name='two');

  // !  DA.Clear;

  // !  assert(DA.Count=0);

  // !  DA.Add(TMyObject.Create('new'));

  // !  assert(DA.Count=1);

  // !end; // will auto-release DA (no need of try..finally DA.Free)

  TObjectDynArrayWrapper = class(TInterfacedObject, IObjectDynArray)

  protected

    fValue: PPointer;

    fCount: integer;

  public

    /// initialize the wrapper with a one-dimension dynamic array of TObject

    constructor Create(var aValue);

    /// 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

    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;

    /// returns the number of TObject instances available

    // - note that the length() of the associated dynamic array is used to store

    // the capacity of the list, so won't probably never match with this value

    function Count: integer;

    /// returns the internal array capacity of TObject instances available

    // - which is in fact the length() of the associated dynamic array

    function Capacity: integer;

  end;



  /// abstract class able to use hashing to find an object in O(1) speed

  // - all protected abstract methods shall be overridden and implemented

  // - use this class instead of a plain TDynArrayHashed, since it would

  // feature its own dedicated hashing, and any abstract mean of value storage

  TObjectHash = class

  protected

    fHashs: TSynHashDynArray;

    procedure HashInit(aCountToHash: integer);

    function HashFind(aHashCode: cardinal; Item: TObject): integer;

    /// abstract method to hash an item

    // - note that the overridden method shall not return 0 (mark void fHashs[])

    function Hash(Item: TObject): cardinal; virtual; abstract;

    /// abstract method to compare two items

    function Compare(Item1,Item2: TObject): boolean; virtual; abstract;

    /// abstract method to get an item

    // - shall return nil if Index is out of range (e.g. >= Count)

    // - will be called e.g. by Find() with Compare() to avoid collision

    function Get(Index: integer): TObject; virtual; abstract;

    /// used to retrieve the number of items

    function Count: integer; virtual; abstract;

  public

    /// search one item in the internal hash array

    function Find(Item: TObject): integer;

    /// search one item using slow list browsing

    // - this version expects the internal list count to be supplied, if some

    // last items are to be ignored (used e.g. in EnsureJustAddedNotDuplicated)

    function Scan(Item: TObject; ListCount: integer): integer; virtual;

    /// to be called when an item is modified

    // - for Delete/Update will force a full rehash on next Find() call

    procedure Invalidate;

    /// to be called when an item has just been added

    // - the index of the latest added item should be Count-1

    // - this method will update the internal hash table, and check if

    // the newly added value is not duplicated

    // - return FALSE if this item is already existing (i.e. insert error)

    // - return TRUE if has been added to the internal hash table

    function EnsureJustAddedNotDuplicated: boolean;

  end;



  /// abstract parent class with a virtual constructor, ready to be overridden

  // to initialize the instance

  // - you can specify such a class if you need an object including published

  // properties (like TPersistent) with a virtual constructor (e.g. to

  // initialize some nested class properties)

  TPersistentWithCustomCreate = class(TPersistent)

  public

    /// this virtual constructor will be called at instance creation

    // - this constructor does nothing, but is declared as virtual so that

    // inherited classes may safely override this default void implementation

    constructor Create; virtual;

  end;



  {$M+}

  /// abstract parent class with threadsafe implementation of IInterface and

  // a virtual constructor

  // - you can specify e.g. such a class to TSQLRestServer.ServiceRegister() if

  // you need an interfaced object with a virtual constructor, ready to be

  // overridden to initialize the instance

  TInterfacedObjectWithCustomCreate = class(TInterfacedObject)

  public

    /// this virtual constructor will be called at instance creation

    // - this constructor does nothing, but is declared as virtual so that

    // inherited classes may safely override this default void implementation

    constructor Create; virtual;

    /// used to mimic TInterfacedObject reference counting

    // - Release=true will call TInterfacedObject._Release

    // - Release=false will call TInterfacedObject._AddRef

    // - could be used to emulate proper reference counting of the instance

    // via interfaces variables, but still storing plain class instances

    // (e.g. in a global list of instances)

    procedure RefCountUpdate(Release: boolean); virtual;

  end;



  /// our own empowered TPersistent-like parent class

  // - TPersistent has an unexpected speed overhead due a giant lock introduced

  // to manage property name fixup resolution (which we won't use outside the VCL)

  // - this class has a virtual constructor, so is a preferred alternative

  // to both TPersistent and TPersistentWithCustomCreate classes

  // - for best performance, any type inheriting from this class will bypass

  // some regular steps: do not implement interfaces or use TMonitor with them!

  TSynPersistent = class(TObject)

  protected

    // this default implementation will call AssignError()

    procedure AssignTo(Dest: TSynPersistent); virtual;

    procedure AssignError(Source: TSynPersistent);

  public

    /// this virtual constructor will be called at instance creation

    // - this constructor does nothing, but is declared as virtual so that

    // inherited classes may safely override this default void implementation

    constructor Create; virtual;

    /// allows to implement a TPersistent-like assignement mechanism

    // - inherited class should override AssignTo() protected method

    // to implement the proper assignment

    procedure Assign(Source: TSynPersistent); virtual;

    {$ifndef FPC_OR_PUREPASCAL}

    /// optimized x86 asm initialization code

    // - warning: this optimized version won't initialize the vmtIntfTable

    // for this class hierarchy: as a result, you would NOT be able to

    // implement an interface with a TSynPersistent descendent (but you should

    // not need to, but inherit from TInterfacedObject)

    class function NewInstance: TObject; override;

    /// 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 TSynPersistentLocked class

    procedure FreeInstance; override;

    {$endif}

  end;

  {$M-}



  /// allow to add cross-platform locking methods to any class instance

  // - typical use is to define a Safe: TSynLocker property, call Safe.Init

  // and Safe.Done in constructor/destructor methods, and use Safe.Lock/UnLock

  // methods in a try ... finally section

  // - in respect to the TCriticalSection class, fix a potential CPU cache line

  // conflict which may degrade the multi-threading performance, as reported by

  // @http://www.delphitools.info/2011/11/30/fixing-tcriticalsection

  // - internal padding is used to safely store up to 7 values protected

  // from concurrent access with a mutex

  {$ifdef UNICODE}

  TSynLocker = record

  {$else}

  TSynLocker = object

  {$endif}

  private

    fSection: TRTLCriticalSection;

    {$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 GetUnlockedInt64(Index: integer): Int64;

    procedure SetUnlockedInt64(Index: integer; const Value: Int64);

    function GetPointer(Index: integer): Pointer;

    procedure SetPointer(Index: integer; const Value: Pointer);

    function GetUTF8(Index: integer): RawUTF8;

    procedure SetUTF8(Index: integer; const Value: RawUTF8);

    {$endif}

  public

    /// internal padding data, also used to store up to 7 variant values

    // - this memory buffer will ensure no CPU cache line mixup occurs

    // - you should not use this field directly, but rather the Locked[],

    // LockedInt64[], LockedUTF8[] or LockedPointer[] methods

    // - if you want to access those array values, ensure you protect them

    // using a Safe.Lock; try ... Padding[n] ... finally Safe.Unlock structure,

    // and maintain the PaddingMaxUsedIndex field accurately

    Padding: array[0..6] of TVarData;

    /// maximum index of the last value stored in the internal Padding[] array

    // - equals -1 if no value is actually stored, or a 0..6 number otherwise

    // - you should not have to use this field, but for optimized low-level

    // direct access to Padding[] values, within a Lock/UnLock safe block

    PaddingMaxUsedIndex: integer;

    /// initialize the mutex

    // - calling this method is mandatory (e.g. in the class constructor owning

    // the TSynLocker instance), otherwise you may encounter unexpected

    // behavior, like access violations or memory leaks

    procedure Init;

    /// finalize the mutex

    // - calling this method is mandatory (e.g. in the class constructor owning

    // the TSynLocker instance), otherwise you may encounter unexpected

    // behavior, like access violations or memory leaks

    procedure Done;

    /// lock the instance for exclusive access

    // - use as such to avoid race condition (from a Safe: TSynLocker property):

    // ! Safe.Lock;

    // ! try

    // !   ...

    // ! finally

    // !   Safe.Unlock;

    // ! end;

    procedure Lock;

      {$ifdef HASINLINE}inline;{$endif}

    /// will try to acquire the mutex

    // - use as such to avoid race condition (from a Safe: TSynLocker property):

    // ! if Safe.TryLock then

    // ! try

    // !   ...

    // ! finally

    // !   Safe.Unlock;

    // ! end;

    function TryLock: boolean;

      {$ifdef HASINLINE}inline;{$endif}

    /// release the instance for exclusive access

    procedure UnLock;

      {$ifdef HASINLINE}inline;{$endif}

    /// will enter the mutex until the IUnknown reference is released

    // - could be used as such under Delphi:

    // !begin

    // !  ... // unsafe code

    // !  Safe.ProtectMethod;

    // !  ... // thread-safe code

    // !end; // local hidden IUnknown will release the lock for the method

    // - warning: under FPC, you should assign its result to a local variable -

    // see bug http://bugs.freepascal.org/view.php?id=26602

    // !var LockFPC: IUnknown;

    // !begin

    // !  ... // unsafe code

    // !  LockFPC := Safe.ProtectMethod;

    // !  ... // thread-safe code

    // !end; // LockFPC will release the lock for the method

    // or

    // !begin

    // !  ... // unsafe code

    // !  with Safe.ProtectMethod do begin

    // !    ... // thread-safe code

    // !  end; // local hidden IUnknown will release the lock for the method

    // !end;

    function ProtectMethod: IUnknown;

    {$ifndef NOVARIANTS}

    /// safe locked access to a Variant value

    // - you may store up to 7 variables, using an 0..6 index, shared with

    // 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 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 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

  TSynPersistentLocked = class(TSynPersistent)

  protected

    fSafe: TSynLocker;

  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: TSynLocker read fSafe;

  end;



  /// adding locking methods to a TInterfacedObject with virtual constructor

  TInterfacedObjectLocked = class(TInterfacedObjectWithCustomCreate)

  protected

    fSafe: TSynLocker;

  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: TSynLocker 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;





  /// 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(TSynPersistent)

  protected

    fCount: Integer;

    fTask: TPendingTaskListItemDynArray;

    fTasks: TDynArray;

    fSafe: TSynLocker;

    function GetCount: integer;

    function GetTimeStamp: Int64; virtual;

  public

    /// initialize the list memory and resources

    constructor Create; override;

    /// finaalize the list memory and resources

    destructor Destroy; 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 locking methods of this instance

    // - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block

    property Safe: TSynlocker read fSafe;

    /// 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;



  /// store one Name/Value pair, as used by TSynNameValue class

  TSynNameValueItem = record

    /// the name of the Name/Value pair

    // - this property is hashed by TSynNameValue for fast retrieval

    Name: RawUTF8;

    /// the value of the Name/Value pair

    Value: RawUTF8;

    /// any associated Pointer or numerical value

    Tag: PtrInt;

  end;



  /// Name/Value pairs storage, as used by TSynNameValue class

  TSynNameValueItemDynArray = array of TSynNameValueItem;



  /// event handler used to convert on the fly some UTF-8 text content

  TConvertRawUTF8 = function(const text: RawUTF8): RawUTF8 of object;



  /// callback event used by TSynNameValue

  TSynNameValueNotify = procedure(const Item: TSynNameValueItem; Index: PtrInt) of object;



  /// pseudo-class used to store Name/Value RawUTF8 pairs

  // - use internaly a TDynArrayHashed instance for fast retrieval

  // - is therefore faster than TRawUTF8List

  // - is defined as an object, not as a class: you can use this in any

  // class, without the need to destroy the content

  // - is defined either as an object either as a record, due to a bug

  // in Delphi 2009/2010 compiler (at least): this structure is not initialized

  // if defined as an object on the stack, but will be as a record :(

  TSynNameValue = {$ifndef UNICODE}object{$else}record{$endif}

    fDynArray: TDynArrayHashed;

    fOnAdd: TSynNameValueNotify;

    function GetBlobData: RawByteString;

    procedure SetBlobData(const aValue: RawByteString);

    function GetStr(const aName: RawUTF8): RawUTF8; {$ifdef HASINLINE}inline;{$endif}

    function GetInt(const aName: RawUTF8): Int64; {$ifdef HASINLINE}inline;{$endif}

    function GetBool(const aName: RawUTF8): Boolean; {$ifdef HASINLINE}inline;{$endif}

  public

    /// the internal Name/Value storage

    List: TSynNameValueItemDynArray;

    /// the number of Name/Value pairs

    Count: integer;

    /// initialize the storage

    // - will also reset the internal List[] and the internal hash array

    procedure Init(aCaseSensitive: boolean);

    /// add an element to the array

    // - if aName already exists, its associated Value will be updated

    procedure Add(const aName, aValue: RawUTF8; aTag: PtrInt=0);

    /// reset content, then add all name=value pairs from a supplied .ini file

    // section content

    // - will first call Init(false) to initialize the internal array

    // - Section can be retrieved e.g. via FindSectionFirstLine()

    procedure InitFromIniSection(Section: PUTF8Char; OnTheFlyConvert: TConvertRawUTF8=nil;

      OnAdd: TSynNameValueNotify=nil);

    /// reset content, then add all name=value; CSV pairs 

    // - will first call Init(false) to initialize the internal array

    procedure InitFromCSV(CSV: PUTF8Char; NameValueSep: AnsiChar='=';

      ItemSep: AnsiChar=#10);

    /// 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;

    /// returns all values, as CSV or INI content

    function AsCSV(const KeySeparator: RawUTF8='=';

      const ValueSeparator: RawUTF8=#13#10; const IgnoreKey: RawUTF8=''): 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); 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): integer;

    {$endif}

    /// returns true if the Init() method has been called

    function Initialized: boolean;

    /// can be used to set all data from one BLOB memory buffer

    procedure SetBlobDataPtr(aValue: pointer);

    /// can be used to set or retrieve all stored data as one BLOB content

    property BlobData: RawByteString read GetBlobData write SetBlobData;

    /// event triggerred after an item has just been added to the list

    property OnAfterAdd: TSynNameValueNotify read fOnAdd write fOnAdd;

    /// search for a Name, return the associated Value as a UTF-8 string

    // - returns '' if aName is not found in the stored keys

    property Str[const aName: RawUTF8]: RawUTF8 read GetStr; default;

    /// search for a Name, return the associated Value as integer

    // - returns 0 if aName is not found, or not a valid Int64 in the stored keys

    property Int[const aName: RawUTF8]: Int64 read GetInt;

    /// search for a Name, return the associated Value as boolean

    // - returns true if aName stores '1' as associated value

    property Bool[const aName: RawUTF8]: Boolean read GetBool;

  end;



  /// a reference pointer to a Name/Value RawUTF8 pairs storage

  PSynNameValue = ^TSynNameValue;



/// 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 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): integer;

  {$ifdef HASINLINE}inline;{$endif}



/// wrapper to add once an item to a T*ObjArray dynamic array storage

// - as expected by TJSONSerializer.RegisterObjArrayForJSON()

// - if the object is already in the array (searching by address/reference,

// not by content), return its current index in the dynamic array

// - if the object does not appear in the array, add it at the end

procedure ObjArrayAddOnce(var aObjArray; aItem: TObject);



/// wrapper to set the length of a T*ObjArray dynamic array storage

// - could be used as an alternative to SetLength() when you do not

// know the exact T*ObjArray type

procedure ObjArraySetLength(var aObjArray; aLength: integer);

  {$ifdef HASINLINE}inline;{$endif}



/// wrapper to search an item in a T*ObjArray dynamic array storage

// - as expected by TJSONSerializer.RegisterObjArrayForJSON()

// - search is performed by address/reference, not by content

// - returns -1 if the item is not found in the dynamic array

function ObjArrayFind(const aObjArray; aItem: TObject): integer;

  {$ifdef HASINLINE}inline;{$endif}



/// 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: integer); 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): integer; 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);



/// wrapper to release all items stored in an array of T*ObjArray dynamic array

// - e.g. aObjArray may be defined as "array of array of TSynFilter"

procedure ObjArrayObjArrayClear(var aObjArray);



/// wrapper to release all items stored in several T*ObjArray dynamic arrays

// - as expected by TJSONSerializer.RegisterObjArrayForJSON()

procedure ObjArraysClear(const aObjArray: array of pointer);



{$ifndef DELPHI5OROLDER}



/// wrapper to add an item to a T*InterfaceArray dynamic array storage

function InterfaceArrayAdd(var aInterfaceArray; const aItem: IUnknown): integer;



/// 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): integer;

  {$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): integer; 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: integer); overload;



{$endif DELPHI5OROLDER}





/// helper to retrieve the text of an enumerate item

// - you'd better use RTTI related classes of mORMot.pas unit, e.g. TEnumType

function GetEnumName(aTypeInfo: pointer; aIndex: integer): PShortString;



/// helper to retrieve the index of an enumerate item from its text

// - returns -1 if aValue was not found

// - will search for the exact text and also trim the lowercase 'a'..'z' chars on

// left side of the text if no exact match is found and AlsoTrimLowerCase is TRUE

// - see also RTTI related classes of mORMot.pas unit, e.g. TEnumType

function GetEnumNameValue(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: integer;

  AlsoTrimLowerCase: boolean=false): Integer; overload;



/// retrieve the index of an enumerate item from its left-trimmed text

// - will trim the lowercase 'a'..'z' chars on left side of the supplied aValue text

// - returns -1 if aValue was not found

function GetEnumNameValueTrimmed(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: integer): integer;



/// helper to retrieve the index of an enumerate item from its text

function GetEnumNameValue(aTypeInfo: pointer; const aValue: RawUTF8;

  AlsoTrimLowerCase: boolean=false): Integer; overload;



/// helper to retrieve the bit mapped integer value of a set from its JSON text

// - if supplied P^ is a JSON integer number, will read it directly

// - if P^ maps some ["item1","item2"] content, would fill all matching bits

// - if P^ contains ['*'], would fill all bits

function GetSetNameValue(aTypeInfo: pointer; var P: PUTF8Char;

  out EndOfObject: AnsiChar): cardinal;



/// fast search of an exact case-insensitive match of a RTTI's PShortString array

function FindShortStringListExact(List: PShortString; MaxValue: integer;

  aValue: PUTF8Char; aValueLen: integer): integer;



/// fast search of an left-trimmed lowercase match of a RTTI's PShortString array

function FindShortStringListTrimLowerCase(List: PShortString; MaxValue: integer;

  aValue: PUTF8Char; aValueLen: integer): 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='');



/// 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;



/// compare two TGUID values

// - this version is faster than the one supplied by SysUtils

function IsEqualGUID(const guid1, guid2: TGUID): Boolean;

  {$ifdef HASINLINE}inline;{$endif}



/// returns the index of a matching TGUID in an array

// - returns -1 if no item matched

function IsEqualGUIDArray(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(const 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(const 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(const guid: TGUID): string;



/// fill some memory buffer with random values

// - the destination buffer is expected to be allocated as 32 bit items

// - use internally crc32c() hashing with some rough entropy source, and

// hardware RDRAND Intel x86/x64 opcode if available

// - consider using instead the cryptographic secure TAESPRNG.Main.FillRandom()

// method from the SynCrypto unit

procedure FillRandom(Dest: PCardinalArray; CardinalCount: integer);



/// 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}



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(const guid: TGUID): TGUIDShortString;



/// convert some text into its TGUID binary value

// - expect e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' (without any {})

// - return  if the supplied text buffer is not a valid TGUID

// - this will be the format used for JSON encoding, e.g.

// $ { "UID": "C9A646D3-9C61-4CB7-BFCD-EE2522C8F633" }

function TextToGUID(P: PUTF8Char; guid: PByteArray): PUTF8Char;



/// convert some text into a TGUID

// - expect e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {})

// - return {00000000-0000-0000-0000-000000000000} if the supplied text buffer

// is not a valid TGUID

function StringToGUID(const text: string): TGUID;



/// convert some UTF-8 encoded text into a TGUID

// - expect e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {})

// - return {00000000-0000-0000-0000-000000000000} if the supplied text buffer

// is not a valid TGUID

function RawUTF8ToGUID(const text: RawByteString): TGUID;





/// 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'

procedure SaveJSON(const Value; TypeInfo: pointer;

  EnumSetsAsText: boolean; 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}





/// 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): 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

// - 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 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

// - 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;



/// save a record content into a Base-64 encoded UTF-8 text content

// - will use RecordSave() format, with a left-sided binary CRC

function RecordSaveBase64(const Rec; TypeInfo: pointer; UriCompatible: boolean=false): RawUTF8;



/// compute the number of bytes needed to save a record content

// using the RecordSave() function

// - will return 0 in case of an invalid (not handled) record type (e.g. if

// it contains an unknown variant)

function RecordSaveLength(const Rec; TypeInfo: pointer): 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

function RecordLoad(var Rec; Source: PAnsiChar; TypeInfo: pointer): PAnsiChar;



/// read a record content from a Base-64 encoded content

// - expects RecordSaveBase64() format, with a left-sided binary CRC

function RecordLoadBase64(Source: PAnsiChar; Len: integer; var Rec; TypeInfo: pointer;

  UriCompatible: boolean=false): boolean;



/// fill a record content from a JSON serialization as saved by

// TTextWriter.AddRecordJSON / RecordSaveJSON

// - will use default Base64 encoding over RecordSave() binary - or custom true

// JSON format (as set by TTextWriter.RegisterCustomJSONSerializer or via

// enhanced RTTI), if available

// - returns nil on error, or the end of buffer on success

// - warning: the JSON buffer will be modified in-place during process - use

// a temporary copy if you need to access it later, or the overloaded RecordLoadJSON()

function RecordLoadJSON(var Rec; JSON: PUTF8Char; TypeInfo: pointer;

  EndOfObject: PUTF8Char=nil): PUTF8Char; overload;



/// fill a record content from a JSON serialization as saved by

// TTextWriter.AddRecordJSON / RecordSaveJSON

// - will use default Base64 encoding over RecordSave() binary - or custom true

// JSON format (as set by TTextWriter.RegisterCustomJSONSerializer or via

// enhanced RTTI), if available

function RecordLoadJSON(var Rec; const JSON: RawUTF8; TypeInfo: pointer): boolean; overload;



/// copy a record content from source to Dest

// - this unit includes a fast optimized asm version for x86

procedure RecordCopy(var Dest; const Source; TypeInfo: pointer);



/// clear a record content

// - this unit includes a fast optimized asm version for x86

procedure RecordClear(var Dest; TypeInfo: pointer);



{$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}



/// 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.Load()

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 array field

// - just a function helper around TDynArray.Load()

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

// - to be used e.g. for custom record JSON unserialization, within a

// TDynArrayJSONCustomReader callback

// - warning: the JSON buffer will be modified in-place during process - use

// a temporary copy if you need to access it later

function DynArrayLoadJSON(var Value; JSON: PUTF8Char; TypeInfo: pointer;

  EndOfObject: PUTF8Char=nil): PUTF8Char;



/// serialize a dynamic array content as JSON

// - Value shall be set to the source dynamic array field

// - is just a wrapper around TTextWriter.AddDynArrayJSON(), creating

// a temporary TDynArray wrapper on the stack

// - to be used e.g. for custom record JSON serialization, within a

// TDynArrayJSONCustomWriter callback or RegisterCustomJSONSerializerFromText()

// (following EnumSetsAsText optional parameter for nested enumerates and sets)

function DynArraySaveJSON(const Value; TypeInfo: pointer;

  EnumSetsAsText: boolean=false): RawUTF8; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// serialize a dynamic array content, supplied as raw binary, 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 DynArraySaveJSON(TypeInfo: pointer; const BlobValue: RawByteString): RawUTF8;

  overload;



/// 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): RawUTF8;



/// compare two "array of boolean" elements

function SortDynArrayBoolean(const A,B): integer;



/// compare two "array of byte" elements

function SortDynArrayByte(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 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 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;



{$ifndef NOVARIANTS}

/// compare two "array of variant" elements, with case sensitivity

function SortDynArrayVariant(const A,B): integer;



/// compare two "array of variant" elements, with no case sensitivity

function SortDynArrayVariantI(const A,B): integer;



/// compare two "array of variant" elements, with or without case sensitivity

function SortDynArrayVariantComp(const A,B: TVarData; caseInsensitive: boolean): integer;

{$endif NOVARIANTS}





/// hash one AnsiString content with the suppplied Hasher() function

function HashAnsiString(const Elem; Hasher: THasher): cardinal;



/// case-insensitive hash one AnsiString content with the suppplied Hasher() function

function HashAnsiStringI(const Elem; Hasher: THasher): cardinal;



/// hash one SynUnicode content with the suppplied Hasher() function

// - work with WideString for all Delphi versions, or UnicodeString in Delphi 2009+

function HashSynUnicode(const Elem; Hasher: THasher): cardinal;



/// case-insensitive hash one SynUnicode content with the suppplied Hasher() function

// - work with WideString for all Delphi versions, or UnicodeString in Delphi 2009+

function HashSynUnicodeI(const Elem; Hasher: THasher): cardinal;



/// hash one WideString content with the suppplied Hasher() function

// - work with WideString for all Delphi versions

function HashWideString(const Elem; Hasher: THasher): cardinal;



/// case-insensitive hash one WideString content with the suppplied Hasher() function

// - work with WideString for all Delphi versions

function HashWideStringI(const Elem; Hasher: THasher): cardinal;



{$ifdef UNICODE}

/// hash one UnicodeString content with the suppplied Hasher() function

// - work with UnicodeString in Delphi 2009+

function HashUnicodeString(const Elem; Hasher: THasher): cardinal;



/// case-insensitive hash one UnicodeString content with the suppplied Hasher() function

// - work with UnicodeString in Delphi 2009+

function HashUnicodeStringI(const Elem; Hasher: THasher): cardinal;

{$endif UNICODE}



{$ifndef NOVARIANTS}

/// case-sensitive hash one variant content with the suppplied Hasher() function

function HashVariant(const Elem; Hasher: THasher): cardinal;



/// case-insensitive hash one variant content with the suppplied Hasher() function

function HashVariantI(const Elem; Hasher: THasher): cardinal;

{$endif NOVARIANTS}



/// hash one PtrUInt (=NativeUInt) value with the suppplied Hasher() function

function HashPtrUInt(const Elem; Hasher: THasher): cardinal;



/// hash one Byte value - simply return the value ignore Hasher() parameter

function HashByte(const Elem; Hasher: THasher): cardinal;



/// hash one Word value - simply return the value ignore Hasher() parameter

function HashWord(const Elem; Hasher: THasher): cardinal;



/// hash one Integer value - simply return the value ignore Hasher() parameter

function HashInteger(const Elem; Hasher: THasher): cardinal;



/// hash one Cardinal value - simply return the value ignore Hasher() parameter

function HashCardinal(const Elem; Hasher: THasher): cardinal;



/// hash one Int64 value with the suppplied Hasher() function

function HashInt64(const Elem; Hasher: THasher): cardinal;



/// hash one pointer value with the suppplied Hasher() function

// - this version is not the same as HashPtrUInt, since it will always

// use the hasher function

function HashPointer(const Elem; Hasher: THasher): cardinal;





var

  /// helper array to get the comparison function corresponding to a given

  // standard array type

  // - not to be used as such, but e.g. when inlining TDynArray methods

  DYNARRAY_SORTFIRSTFIELD: array[boolean,TDynArrayKind] of TDynArraySortCompare = (

    (nil, SortDynArrayBoolean, SortDynArrayByte, SortDynArrayWord,

    SortDynArrayInteger, SortDynArrayCardinal, SortDynArraySingle,

    SortDynArrayInt64, SortDynArrayDouble,

    SortDynArrayInt64, SortDynArrayInt64, SortDynArrayDouble,

    SortDynArrayAnsiString, SortDynArrayAnsiString, SortDynArrayString,

    SortDynArrayAnsiString, SortDynArrayUnicodeString,

    SortDynArrayUnicodeString, SortDynArrayPointer,

    {$ifndef NOVARIANTS}SortDynArrayVariant,{$endif} nil),

    (nil, SortDynArrayBoolean, SortDynArrayByte, SortDynArrayWord,

    SortDynArrayInteger, SortDynArrayCardinal, SortDynArraySingle,

    SortDynArrayInt64, SortDynArrayDouble,

    SortDynArrayInt64, SortDynArrayInt64, SortDynArrayDouble,

    SortDynArrayAnsiStringI, SortDynArrayAnsiStringI, SortDynArrayStringI,

    SortDynArrayAnsiStringI, SortDynArrayUnicodeStringI,

    SortDynArrayUnicodeStringI, SortDynArrayPointer,

    {$ifndef NOVARIANTS}SortDynArrayVariantI,{$endif} nil));



  /// helper array to get the hashing function corresponding to a given

  // standard array type

  // - not to be used as such, but e.g. when inlining TDynArray methods

  DYNARRAY_HASHFIRSTFIELD: array[boolean,TDynArrayKind] of TDynArrayHashOne = (

    (nil, HashByte, HashByte, HashWord, HashInteger,

    HashCardinal, HashCardinal, HashInt64, HashInt64,

    HashInt64, HashInt64, HashInt64,

    HashAnsiString, HashAnsiString,

    {$ifdef UNICODE}HashUnicodeString{$else}HashAnsiString{$endif},

    HashAnsiString, HashWideString, HashSynUnicode, HashPointer,

    {$ifndef NOVARIANTS}HashVariant,{$endif} nil),

    (nil, HashByte, HashByte, HashWord, HashInteger,

    HashCardinal, HashCardinal, HashInt64, HashInt64,

    HashInt64, HashInt64, HashInt64,

    HashAnsiStringI, HashAnsiStringI,

    {$ifdef UNICODE}HashUnicodeStringI{$else}HashAnsiStringI{$endif},

    HashAnsiStringI, HashWideStringI, HashSynUnicodeI, 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): 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

// - a bit 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: integer; CaseSensitive: boolean): integer;



var

  /// mORMot.pas will registry here its T*ObjArray serialization process

  DynArrayIsObjArray: function(aDynArrayTypeInfo: Pointer): boolean;





{ ****************** 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)

  // - default is 64, but can be set to any value (64, 128, 192 and 256 optimized)

  // - 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 Delphi compiler restriction, 256 is the maximum value

  // (this is the maximum number of items in a Delphi set)

  MAX_SQLFIELDS = 64;



  /// 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

  /// 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;



  /// 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, and currency as double or

  // BCD in most databases

  TSQLVar = record

    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, 256 bits uses 64 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;



  TTextWriter = class;



  /// method prototype for custom serialization of a dynamic array item

  // - each element of the dynamic array will be called as aValue parameter

  // of this callback

  // - can be used also at record level, if the record has a type information

  // (i.e. shall contain a managed type within its fields)

  // - to be used with TTextWriter.RegisterCustomJSONSerializer() method

  // - note that the generated JSON content will be appended after a '[' and

  // before a ']' as a normal JSON arrray, but each item can be any JSON

  // structure (i.e. a number, a string, but also an object or an array)

  // - implementation code could call aWriter.Add/AddJSONEscapeString...

  // - implementation code shall follow the same exact format for the

  // associated TDynArrayJSONCustomReader callback

  TDynArrayJSONCustomWriter = procedure(const aWriter: TTextWriter; const aValue) of object;



  /// method prototype for custom unserialization of a dynamic array item

  // - each element of the dynamic array will be called as aValue parameter

  // of this callback

  // - can be used also at record level, if the record has a type information

  // (i.e. shall contain a managed type within its fields)

  // - to be used with TTextWriter.RegisterCustomJSONSerializer() method

  // - implementation code could call e.g. GetJSONField() low-level function, and

  // returns a pointer to the last handled element of the JSON input buffer,

  // as such (aka EndOfBuffer variable as expected by GetJSONField):

  // ! var V: TFV absolute aValue;

  // ! begin

  // !   (...)

  // !   V.Detailed := UTF8ToString(GetJSONField(P,P));

  // !   if P=nil then

  // !     exit;

  // !   aValid := true;

  // !   result := P; // ',' or ']' for last item of array

  // ! end;

  // - implementation code shall follow the same exact format for the

  // associated TDynArrayJSONCustomWriter callback

  TDynArrayJSONCustomReader = function(P: PUTF8Char; var aValue;

    out aValid: Boolean): PUTF8Char of object;



  /// the kind of variables handled by TJSONCustomParser

  // - the last item should be ptCustom, for non simple types

  TJSONCustomParserRTTIType = (

    ptArray, ptBoolean, ptByte, ptCardinal, ptCurrency, ptDouble, ptExtended,

    ptInt64, ptInteger, ptRawByteString, ptRawJSON, ptRawUTF8, ptRecord,

    ptSingle, ptString, ptSynUnicode, ptDateTime, ptGUID, ptID, ptTimeLog,

    {$ifndef NOVARIANTS}ptVariant, {$endif}

    ptWideString, ptWord, ptCustom);



  /// how TJSONCustomParser would serialize/unserialize JSON content

  TJSONCustomParserSerializationOption = (

    soReadIgnoreUnknownFields, soWriteHumanReadable,

    soCustomVariantCopiedByReference);



  /// 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

  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);

  public

    /// initialize the instance

    constructor Create(const aPropertyName: RawUTF8;

      aPropertyType: TJSONCustomParserRTTIType);

    /// initialize an instance from the RTTI type information

    // - will return an instance of this class of any inherited class

    class function CreateFromRTTI(const PropertyName: RawUTF8;

      Info: pointer; ItemSize: integer): TJSONCustomParserRTTI;

    /// create an instance from a specified type name

    // - will return an instance of this class of any inherited class

    class function CreateFromTypeName(const aPropertyName,

      aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI;

    /// recognize a simple type from a supplied type name

    // - will return ptCustom for any unknown type

    class function TypeNameToSimpleRTTIType(

      const TypeName: RawUTF8): TJSONCustomParserRTTIType; overload;

    /// recognize a simple type from a supplied type name

    // - will return ptCustom for any unknown type

    class function TypeNameToSimpleRTTIType(

      TypeName: PShortString): TJSONCustomParserRTTIType; overload;

    /// recognize a simple type from a supplied type name

    // - will return ptCustom for any unknown type

    class function TypeNameToSimpleRTTIType(TypeName: PUTF8Char; TypeNameLen: Integer;

      var ItemTypeName: RawUTF8): TJSONCustomParserRTTIType; overload;

    /// recognize a simple type from a supplied type information

    // - to be called if TypeNameToSimpleRTTIType() did fail, i.e. return ptCustom

    // - will return ptCustom for any unknown type

    class function TypeInfoToSimpleRTTIType(Info: pointer; ItemSize: integer): TJSONCustomParserRTTIType;

    /// unserialize some JSON content into its binary internal representation

    // - on error, returns false and P should point to the faulty text input

    function ReadOneLevel(var P: PUTF8Char; var Data: PByte;

      Options: TJSONCustomParserSerializationOptions): boolean; virtual;

    /// serialize a binary internal representation into JSON content

    // - this method won't append a trailing ',' character

    procedure WriteOneLevel(aWriter: TTextWriter; var P: PByte;

      Options: TJSONCustomParserSerializationOptions); virtual;

    /// the associated type name, e.g. for a record

    property CustomTypeName: RawUTF8 read fCustomTypeName;

    /// the property name

    // - may be void for the Root element

    // - e.g. 'SubProp'

    property PropertyName: RawUTF8 read fPropertyName;

    /// the property name, including all parent elements

    // - may be void for the Root element

    // - e.g. 'MainProp.SubProp'

    property FullPropertyName: RawUTF8 read fFullPropertyName;

    /// the property type

    // - support only a limited set of simple types, or ptRecord for a nested

    // record, or ptArray for a nested array

    property PropertyType: TJSONCustomParserRTTIType read fPropertyType;

    /// the nested array of properties (if any)

    // - assigned only if PropertyType is [ptRecord,ptArray]

    // - is either the record type of each ptArray item:

    // ! SubProp: array of record ...

    // - or one NestedProperty[0] entry with PropertyName='' and PropertyType

    // not in [ptRecord,ptArray]:

    // ! SubPropNumber: array of integer;

    // ! SubPropText: array of RawUTF8;

    property NestedProperty: TJSONCustomParserRTTIs read fNestedProperty;

  end;



  /// used to store additional RTTI as a ptCustom kind of property

  TJSONCustomParserCustom = class(TJSONCustomParserRTTI)

  protected

    fCustomTypeInfo: pointer;

  public

    /// initialize the instance

    constructor Create(const aPropertyName, aCustomTypeName: RawUTF8); virtual;

    /// abstract method to write the instance as JSON

    procedure CustomWriter(const aWriter: TTextWriter; const aValue); virtual; abstract;

    /// abstract method to read the instance from JSON

    // - should return nil on parsing error

    function CustomReader(P: PUTF8Char; var aValue; out EndOfObject: AnsiChar): PUTF8Char; virtual; abstract;

    /// release any memory used by the instance

    procedure FinalizeItem(Data: Pointer); virtual;

    /// the associated RTTI structure

    property CustomTypeInfo: pointer read fCustomTypeInfo;

  end;



  /// which kind of property does TJSONCustomParserCustomSimple refer to

  TJSONCustomParserCustomSimpleKnownType = (

    ktNone, ktEnumeration, ktSet, ktGUID,

    ktFixedArray, ktStaticArray, ktDynamicArray);



  /// 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);

    /// released used memory

    destructor Destroy; override;

    /// method to write the instance as JSON

    procedure CustomWriter(const aWriter: TTextWriter; const aValue); override;

    /// method to read the instance from JSON

    function CustomReader(P: PUTF8Char; var aValue; out EndOfObject: AnsiChar): PUTF8Char; override;

    /// which kind of simple property this instance does refer to

    property KnownType: TJSONCustomParserCustomSimpleKnownType read fKnownType;

    /// the element type for ktStaticArray and ktDynamicArray

    property NestedArray: TJSONCustomParserRTTI read fNestedArray;

  end;



  /// implement a reference to a registered record type

  // - i.e. ptCustom kind of property, handled by the

  // TTextWriter.RegisterCustomJSONSerializer*() internal list

  TJSONCustomParserCustomRecord = class(TJSONCustomParserCustom)

  protected

    fCustomTypeIndex: integer;

    function GetJSONCustomParserRegistration: pointer;

  public

{    /// initialize the instance from the given RTTI name

    constructor Create(const aPropertyName, aCustomTypeName: RawUTF8); overload; override; }

    /// initialize the instance from the given record custom serialization index

    constructor Create(const aPropertyName: RawUTF8;

      aCustomTypeIndex: integer); reintroduce; overload;

    /// method to write the instance as JSON

    procedure CustomWriter(const aWriter: TTextWriter; const aValue); override;

    /// method to read the instance from JSON

    function CustomReader(P: PUTF8Char; var aValue; out EndOfObject: AnsiChar): PUTF8Char; override;

    /// release any memory used by the instance

    procedure FinalizeItem(Data: Pointer); override;

  end;



  /// how an RTTI expression is expected to finish

  TJSONCustomParserRTTIExpectedEnd = (eeNothing, eeSquare, eeCurly, eeEndKeyWord);



  TJSONRecordAbstract = class;



(* /// implement a reference to a unregistered record type

  // - i.e. ptCustom kind of property, not handled by the

  // TTextWriter.RegisterCustomJSONSerializer*() internal list

  TJSONCustomParserCustomRecord = class(TJSONCustomParserCustom)

  protected

    fCustomRecord: TJSONRecordAbstract;

  public

    /// initialize the instance from the given RTTI name

    constructor Create(const aPropertyName, aCustomTypeName: RawUTF8); overload; override;

    /// initialize the instance from the given record custom serialization index

    constructor Create(const aPropertyName: RawUTF8;

      aCustomTypeIndex: integer); reintroduce; overload;

    /// method to write the instance as JSON

    procedure CustomWriter(const aWriter: TTextWriter; const aValue); override;

    /// method to read the instance from JSON

    function CustomReader(P: PUTF8Char; var aValue; out EndOfObject: AnsiChar): PUTF8Char; override;

    /// release any memory used by the instance

    procedure FinalizeItem(Data: Pointer); override;

  end; *)



  /// used to handle additional RTTI for JSON record serialization

  // - this class is used to define how a record is defined, and will work

  // with any version of Delphi

  // - this Abstract class is not to be used as-this, but contains all

  // needed information to provide CustomWriter/CustomReader methods

  // - you can use e.g. TJSONRecordTextDefinition for text-based RTTI

  // manual definition, or (not yet provided) a version based on Delphi 2010+

  // new RTTI information

  TJSONRecordAbstract = class

  protected

    /// internal storage of TJSONCustomParserRTTI instances

    fItems: TObjectList;

    fRoot: TJSONCustomParserRTTI;

    fOptions: TJSONCustomParserSerializationOptions;

    function AddItem(const aPropertyName: RawUTF8; aPropertyType: TJSONCustomParserRTTIType;

      const aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI;

  public

    /// initialize the class instance

    constructor Create;

    /// callback for custom JSON serialization

    // - will follow the RTTI textual information as supplied to the constructor

    procedure CustomWriter(const aWriter: TTextWriter; const aValue);

    /// callback for custom JSON unserialization

    // - will follow the RTTI textual information as supplied to the constructor

    function CustomReader(P: PUTF8Char; var aValue; out aValid: Boolean): PUTF8Char;

    /// release used memory

    // - when created via Compute() call, instances of this class are managed

    // via a GarbageCollector() global list, so you do not need to free them

    destructor Destroy; override;

    /// store the RTTI information of properties at root level

    // - is one instance with PropertyType=ptRecord and PropertyName=''

    property Root: TJSONCustomParserRTTI read fRoot;

    /// how this class would serialize/unserialize JSON content

    // - by default, no option is defined

    // - you can set the option with the instance returned by

    // TTextWriter.RegisterCustomJSONSerializerFromText() method

    property Options: TJSONCustomParserSerializationOptions read fOptions write fOptions;

  end;



  /// used to handle JSON record serialization using RTTI

  // - is able to handle any kind of record since Delphi 2010, thanks to

  // enhanced RTTI

  TJSONRecordRTTI = class(TJSONRecordAbstract)

  protected

    fRecordTypeInfo: pointer;

    function AddItemFromRTTI(const PropertyName: RawUTF8;

      Info: pointer; ItemSize: integer): TJSONCustomParserRTTI;

    {$ifdef ISDELPHI2010}

    procedure FromEnhancedRTTI(Props: TJSONCustomParserRTTI; Info: pointer);

    {$endif}

  public

    /// initialize the instance

    // - you should NOT use this constructor directly, but let e.g.

    // TJSONCustomParsers.TryToGetFromRTTI() create it for you

    constructor Create(aRecordTypeInfo: pointer; aRoot: TJSONCustomParserRTTI); reintroduce;

    /// the low-level address of the enhanced RTTI

    property RecordTypeInfo: pointer read fRecordTypeInfo;

  end;



  /// used to handle text-defined additional RTTI for JSON record serialization

  // - is used by TTextWriter.RegisterCustomJSONSerializerFromText() method

  TJSONRecordTextDefinition = class(TJSONRecordAbstract)

  protected

     fDefinition: RawUTF8;

    procedure Parse(Props: TJSONCustomParserRTTI; var P: PUTF8Char;

      PEnd: TJSONCustomParserRTTIExpectedEnd);

  public

    /// initialize a custom JSON serializer/unserializer from pseudo RTTI

    // - you should NOT use this constructor directly, but call the FromCache()

    // class function, which will use an internal definition cache

    constructor Create(aRecordTypeInfo: pointer; const aDefinition: RawUTF8); reintroduce;

    /// retrieve a custom cached JSON serializer/unserializer from pseudo RTTI

    // - returned class instance will be cached for any further use

    // - the record where the data will be stored should be defined as PACKED:

    // ! type TMyRecord = packed record

    // !   A,B,C: integer;

    // !   D: RawUTF8;

    // !   E: record; // or array of record/integer/string/...

    // !     E1,E2: double;

    // !   end;

    // ! end;

    // - only known sub types are integer, cardinal, Int64, single, double,

    // currency, TDateTime, TTimeLog, RawUTF8, String, WideString, SynUnicode,

    // or a nested record or dynamic array

    // - RTTI textual information shall be supplied as text, with the

    // same format as with a pascal record, or with some shorter variations:

    // ! FromCache('A,B,C: integer; D: RawUTF8; E: record E1,E2: double; end;');

    // ! FromCache('A,B,C: integer; D: RawUTF8; E: array of record E1,E2: double; end;');

    // ! 'A,B,C: integer; D: RawUTF8; E: array of SynUnicode; F: array of integer'

    // or a shorter alternative syntax for records and arrays:

    // ! FromCache('A,B,C: integer; D: RawUTF8; E: {E1,E2: double}');

    // ! FromCache('A,B,C: integer; D: RawUTF8; E: [E1,E2: double]');

    // in fact ; could be ignored:

    // ! FromCache('A,B,C:integer D:RawUTF8 E:{E1,E2:double}');

    // ! FromCache('A,B,C:integer D:RawUTF8 E:[E1,E2:double]');

    // or even : could be ignored:

    // ! FromCache('A,B,C integer D RawUTF8 E{E1,E2 double}');

    // ! FromCache('A,B,C integer D RawUTF8 E[E1,E2 double]');

    class function FromCache(aTypeInfo: pointer;

      const aDefinition: RawUTF8): TJSONRecordTextDefinition;

    /// the textual definition of this RTTI information

    property Definition: RawUTF8 read fDefinition;

  end;



  /// the available logging events, as handled by TSynLog

  // - defined in SynCommons so that it may be used with TTextWriter.AddEndOfLine

  // - sllInfo will log general information events

  // - sllDebug will log detailed debugging information

  // - sllTrace will log low-level step by step debugging information

  // - sllWarning will log unexpected values (not an error)

  // - sllError will log errors

  // - sllEnter will log every method start

  // - sllLeave will log every method exit

  // - sllLastError will log the GetLastError OS message

  // - sllException will log all exception raised - available since Windows XP

  // - sllExceptionOS will log all OS low-level exceptions (EDivByZero,

  // ERangeError, EAccessViolation...)

  // - sllMemory will log memory statistics

  // - sllStackTrace will log caller's stack trace (it's by default part of

  // TSynLogFamily.LevelStackTrace like sllError, sllException, sllExceptionOS,

  // sllLastError and sllFail)

  // - sllFail was defined for TSynTestsLogged.Failed method, and can be used

  // to log some customer-side assertions (may be notifications, not errors)

  // - sllSQL is dedicated to trace the SQL statements

  // - sllCache should be used to trace the internal caching mechanism

  // - sllResult could trace the SQL results, JSON encoded

  // - sllDB is dedicated to trace low-level database engine features

  // - sllHTTP could be used to trace HTTP process

  // - sllClient/sllServer could be used to trace some Client or Server process

  // - sllServiceCall/sllServiceReturn to trace some remote service or library

  // - sllUserAuth to trace user authentication (e.g. for individual requests)

  // - sllCustom* items can be used for any purpose

  // - sllNewRun will be written when a process opens a rotated log

  // - sllDDDError will log any DDD-related low-level error information

  // - sllDDDInfo will log any DDD-related low-level debugging information

  // - sllMonitoring will log the statistics information (if available),

  // or may be used for real-time chat among connected people to ToolsAdmin

  TSynLogInfo = (

    sllNone, sllInfo, sllDebug, sllTrace, sllWarning, sllError,

    sllEnter, sllLeave,

    sllLastError, sllException, sllExceptionOS, sllMemory, sllStackTrace,

    sllFail, sllSQL, sllCache, sllResult, sllDB, sllHTTP, sllClient, sllServer,

    sllServiceCall, sllServiceReturn, sllUserAuth,

    sllCustom1, sllCustom2, sllCustom3, sllCustom4, sllNewRun,

    sllDDDError, sllDDDInfo, sllMonitoring);



  /// used to define a set of logging level abilities

  // - i.e. a combination of none or several logging event

  // - e.g. use LOG_VERBOSE constant to log all events, or LOG_STACKTRACE

  // to log all errors and exceptions

  TSynLogInfos = set of TSynLogInfo;



  /// a dynamic array of logging event levels

  TSynLogInfoDynArray = array of TSynLogInfo;





  /// available options for TTextWriter.WriteObject() method

  // - woHumanReadable will add some line feeds and indentation to the content,

  // to make it more friendly to the human eye

  // - woDontStoreDefault (which is set by default for WriteObject method) will

  // avoid serializing properties including a default value (JSONToObject function

  // will set the default values, so it may help saving some bandwidth or storage)

  // - woFullExpand will generate a debugger-friendly layout, including instance

  // class name, sets/enumerates as text, and reference pointer - as used by

  // TSynLog and ObjectToJSONFull()

  // - woStoreClassName will add a "ClassName":"TMyClass" field

  // - woStorePointer will add a "Address":"0431298a" field

  // - 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

  TTextWriterWriteObjectOption = (

    woHumanReadable, woDontStoreDefault, woFullExpand,

    woStoreClassName, woStorePointer, woStoreStoredFalse,

    woHumanReadableFullSetsAsStar, woHumanReadableEnumSetAsComment,

    woEnumSetsAsText, woDateTimeWithMagic, woDateTimeWithZSuffix, woTimeLogAsText,

    woIDAsIDstr, woSQLRawBlobAsBase64, woHideSynPersistentPassword,

    woObjectListWontStoreClassName, woDontStoreEmptyString,

    woDontStoreInherited);

  /// options set for TTextWriter.WriteObject() method

  TTextWriterWriteObjectOptions = set of TTextWriterWriteObjectOption;



  /// callback used to echo each line of TTextWriter class

  // - should return TRUE on sucess, FALSE if the log was not echoed: but

  // TSynLog will continue logging, even if this event returned FALSE

  TOnTextWriterEcho = function(Sender: TTextWriter; Level: TSynLogInfo;

    const Text: RawUTF8): boolean of object;

  /// callback used by TTextWriter.WriteObject to customize class instance

  // serialization

  // - should return TRUE if the supplied property has been written (including

  // the property name and the ending ',' character), and doesn't need to be

  // processed with the default RTTI-based serializer

  TOnTextWriterObjectProp = function(Sender: TTextWriter; Value: TObject;

    PropInfo: pointer; Options: TTextWriterWriteObjectOptions): boolean of object;    



  /// class of our simple writer to a Stream, specialized for the TEXT format

  TTextWriterClass = class of TTextWriter;



  /// the 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);



  /// the potential places were TTextWriter.HtmlEscape should process

  // proper HTML string escaping

  // $  < > & "  ->   &lt; &gt; &amp; &quote;

  // by default (hfAnyWhere)

  // $  < > &  ->   &lt; &gt; &amp;

  // outside HTML attributes (hfOutsideAttributes)

  // $  & "  ->   &amp; &quote;

  // within HTML attributes (hfWithinAttributes)

  TTextWriterHTMLFormat = (

    hfAnyWhere, hfOutsideAttributes, hfWithinAttributes);



  /// available global options for a TTextWriter instance

  // - TTextWriter.WriteObject() method behavior would be set via their own

  // TTextWriterWriteObjectOptions, and work in conjunction with those settings

  // - twoStreamIsOwned would be set if the associated TStream is owned by

  // the TTextWriter instance

  // - twoFlushToStreamNoAutoResize would forbid FlushToStream to resize the

  // internal memory buffer when it appears undersized - FlushFinal will set it

  // before calling a last FlushToStream

  // - by default, custom serializers defined via RegisterCustomJSONSerializer()

  // would let AddRecordJSON() and AddDynArrayJSON() write enumerates and sets

  // as integer numbers, unless twoEnumSetsAsTextInRecord is set

  // - 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

  TTextWriterOption = (

    twoStreamIsOwned,

    twoFlushToStreamNoAutoResize,

    twoEnumSetsAsTextInRecord,

    twoForceJSONExtended,

    twoForceJSONStandard,

    twoTrimLeftEnumSets,

    twoEndOfLineCRLF);

  /// 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;



  /// simple writer to a Stream, specialized for the TEXT format

  // - use an internal buffer, faster than string+string

  // - some dedicated methods is able to encode any data with JSON escape

  TTextWriter = class

  protected

    B, BEnd: PUTF8Char;

    fStream: TStream;

    fInitialStreamPosition: cardinal;

    fTotalFileSize: cardinal;                               

    fCustomOptions: TTextWriterOptions;

    // internal temporary buffer

    fTempBufSize: Integer;

    fTempBuf: PUTF8Char;

    fHumanReadableLevel: integer;

    fEchoBuf: RawUTF8;

    fEchoStart: integer;

    fEchos: array of TOnTextWriterEcho;

    fOnWriteObject: TOnTextWriterObjectProp;

    /// used by WriteObjectAsString/AddDynArrayJSONAsString methods

    fInternalJSONWriter: TTextWriter;

    function GetLength: cardinal;

    procedure SetStream(aStream: TStream);

    function EchoFlush: integer;

    procedure InternalAddFixedAnsi(Source: PAnsiChar; SourceChars: Cardinal;

      const AnsiToWide: TWordDynArray; Escape: TTextWriterKind);

    function GetEndOfLineCRLF: boolean;

      {$ifdef HASINLINE}inline;{$endif}

    procedure SetEndOfLineCRLF(aEndOfLineCRLF: boolean);

  public

    /// the data will be written to the specified Stream

    // - aStream may be nil: in this case, it MUST be set before using any

    // Add*() method

    // - default internal buffer size if 8192

    constructor Create(aStream: TStream; aBufSize: integer=8192);

    /// 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)

    constructor CreateOwnedStream(aBufSize: integer=4096);

    /// the data will be written to an external file

    // - you should call explicitly FlushFinal or FlushToStream to write

    // any pending data to the file

    constructor CreateOwnedFileStream(const aFileName: TFileName; aBufSize: integer=8192);

    /// release all internal structures

    // - e.g. free fStream if the instance was owned by this class

    destructor Destroy; override;

    /// you can use this method to override the default JSON serialization class

    // - if only SynCommons.pas is used, it will be TTextWriter

    // - but mORMot.pas will call it to use the TJSONSerializer instead, which

    // is able to serialize any class as JSON

    class procedure SetDefaultJSONClass(aClass: TTextWriterClass);

    /// allow to override the default JSON serialization of enumerations and

    // sets as text, which would write the whole identifier (e.g. 'sllError')

    // - calling SetDefaultEnumTrim(true) would force the enumerations to

    // be trimmed for any lower case char, e.g. sllError -> 'Error'

    // - this is global to the current process, and should be use mainly for

    // compatibility purposes for the whole process

    // - you may change the default behavior by setting twoTrimLeftEnumSets

    // in the TTextWriter.CustomOptions property of a given serializer

    // - note that unserialization process would recognize both formats 

    class procedure SetDefaultEnumTrim(aShouldTrimEnumsAsText: boolean);



    /// retrieve the data as a string

    function Text: RawUTF8;

      {$ifdef HASINLINE}inline;{$endif}

    /// retrieve the data as a string

    // - will avoid creation of a temporary RawUTF8 variable as for Text function

    procedure SetText(var result: RawUTF8);

    /// set the internal stream content with the supplied UTF-8 text

    procedure ForceContent(const text: RawUTF8);

    /// write pending data to the Stream, with automatic buffer resizal

    // - you should not have to call FlushToStream in most cases, but FlushFinal

    // at the end of the process, just before using the resulting Stream

    // - FlushToStream may be used to force immediate writing of the internal

    // memory buffer to the destination Stream

    // - you can set FlushToStreamNoAutoResize=true or call FlushFinal if you

    // do not want the automatic memory buffer resizal to take place

    procedure FlushToStream; virtual;

    /// write pending data to the Stream, without automatic buffer resizal

    // - will append the internal memory buffer to the Stream

    // - in short, FlushToStream may be called during the adding process, and

    // FlushFinal at the end of the process, just before using the resulting Stream

    // - if you don't call FlushToStream or FlushFinal, some pending characters

    // may not be copied to the Stream: you should call it before using the Stream

    procedure FlushFinal;

    /// gives access to an internal temporary TTextWriter

    // - may be used to escape some JSON espaced value (i.e. escape it twice),

    // in conjunction with AddJSONEscape(Source: TTextWriter)

    function InternalJSONWriter: TTextWriter;

    /// add a callback to echo each line written by this class

    // - this class expects AddEndOfLine to mark the end of each line

    procedure EchoAdd(const aEcho: TOnTextWriterEcho);

    /// remove a callback to echo each line written by this class

    // - event should have been previously registered by a EchoAdd() call

    procedure EchoRemove(const aEcho: TOnTextWriterEcho);

    /// reset the internal buffer used for echoing content

    procedure EchoReset;



    /// append one ASCII char to the buffer

    procedure Add(c: AnsiChar); overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// append two chars to the buffer

    procedure Add(c1,c2: AnsiChar); overload;

      {$ifdef HASINLINE}inline;{$endif}

    {$ifndef CPU64} // already implemented by Add(Value: PtrInt) method

    /// append a 64 bit signed Integer Value as text

    procedure Add(Value: Int64); overload;

    {$endif}

    /// append a 32 bit signed Integer Value as text

    procedure Add(Value: PtrInt); overload;

    /// append a boolean Value as text

    // - write either 'true' or 'false'

    procedure Add(Value: boolean); overload;

    /// 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;

    /// append a TTimeLog value, expanded as Iso-8601 encoded text

    procedure AddTimeLog(Value: PInt64);

    /// append a TDateTime value, expanded as Iso-8601 encoded text

    procedure AddDateTime(Value: PDateTime; FirstChar: AnsiChar='T'; QuoteChar: AnsiChar=#0); overload;

    /// append a TDateTime value, expanded as Iso-8601 encoded text

    procedure AddDateTime(const Value: TDateTime); overload;

    /// append an Unsigned Integer Value as a String

    procedure AddU(Value: cardinal);

    /// append a GUID value, encoded as text without any {}

    // - will store e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301'

    procedure Add(const guid: TGUID); overload;

    /// append a floating-point Value as a String

    procedure AddDouble(Value: double);

    /// append a floating-point Value as a String

    procedure AddSingle(Value: single);

    /// append a floating-point Value as a String

    procedure Add(Value: Extended; precision: integer); overload;

    /// append a floating-point text buffer

    // - will correct on the fly '.5' -> '0.5' and '-.5' -> '-0.5'

    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

    // - CR = #13 writes CR+LF chars (i.e. if you write #13 in the Format

    // string, it will output #13#10 chars)

    {$ifdef OLDTEXTWRITERFORMAT}

    // - $ = #36 indicates an integer to be written with 2 digits and a comma

    // - £ = #163 indicates an integer to be written with 4 digits and a comma

    // - µ = #181 indicates an integer to be written with 3 digits without any comma

    // - ¤ = #164 indicates CR+LF chars

    // - § = #167 indicates to trim last comma

    // - | = #124 will write the next char e.g. Add('%|$',[10]) will write '10$'

    // - 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); 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

    procedure AddCR;

    /// mark an end of line, ready to be "echoed" to registered listeners

    // - append a CR (#13) char or CR+LF (#13#10) chars to the buffer, depending

    // on the EndOfLineCRLF property value (default is CR, to minimize storage)

    // - any callback registered via EchoAdd() will monitor this line

    // - used e.g. by TSynLog for console output, as stated by Level parameter

    procedure AddEndOfLine(aLevel: TSynLogInfo=sllNone);

    /// append CR+LF (#13#10) chars and #9 indentation

    // - indentation depth is defined by fHumanReadableLevel protected field

    procedure AddCRAndIndent;

    /// write the same character multiple times

    procedure AddChars(aChar: AnsiChar; aCount: integer);

    /// append an Integer Value as a 2 digits String with comma

    procedure Add2(Value: integer);

    /// append the current UTC date and time, in a log-friendly format

    // - e.g. append '20110325 19241502 '

    // - you may set LocalTime=TRUE to write the local date and time instead

    // - this method is very fast, and avoid most calculation or API calls

    procedure AddCurrentLogTime(LocalTime: boolean=false; Use16msCache: boolean=true);

    /// append a time period, specified in micro seconds

    procedure AddMicroSec(MS: cardinal);

    /// append an Integer Value as a 4 digits String with comma

    procedure Add4(Value: integer);

    /// append an Integer Value as a 3 digits String without any added comma

    procedure Add3(Value: integer);

    /// append a line of text with CR+LF at the end

    procedure AddLine(const Text: shortstring);

    /// append an UTF-8 String, with no JSON escaping

    procedure AddString(const Text: RawUTF8);

      {$ifdef HASINLINE}inline;{$endif}

    /// 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);

      {$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: integer);

    /// append after trim first lowercase chars ('otDone' will add 'Done' e.g.)

    procedure AddTrimLeftLowerCase(Text: PShortString);

    /// append a ShortString property name, as '"PropName":'

    // - PropName content should not need to be JSON escaped (e.g. no " within,

    // and only ASCII 7-bit characters)

    // - if twoForceJSONExtended is defined in CustomOptions, it would append

    // 'PropName:' without the double quotes

    procedure AddPropName(const PropName: ShortString);

    /// append a RawUTF8 property name, as '"FieldName":'

    // - FieldName content should not need to be JSON escaped (e.g. no " within)

    procedure AddFieldName(const FieldName: RawUTF8); overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// append a UTF8-encoded property name, as '"FieldName":'

    // - FieldName content should not need to be JSON escaped (e.g. no " within)

    procedure AddFieldName(FieldName: PUTF8Char; FieldNameLen: integer); overload;

    /// append the class name of an Object instance as text

    // - aClass must be not nil

    procedure AddClassName(aClass: TClass);

    /// append an Instance name and pointer, as '"TObjectList(00425E68)"'+SepChar

    // - Instance must be not nil

    procedure AddInstanceName(Instance: TObject; SepChar: AnsiChar);

    /// append an Instance name and pointer, as 'TObjectList(00425E68)'+SepChar

    // - Instance must be not nil

    // - overriden version in TJSONSerializer would implement IncludeUnitName

    procedure AddInstancePointer(Instance: TObject; SepChar: AnsiChar;

      IncludeUnitName: boolean); virtual;

    /// append a quoted string as JSON, with in-place decoding

    // - if QuotedString does not start with ' or ", it will written directly

    // (i.e. expects to be a number, or null/true/false constants)

    // - as used e.g. by TJSONObjectDecoder.EncodeAsJSON method and

    // JSONEncodeNameSQLValue() function

    procedure AddQuotedStringAsJSON(const QuotedString: RawUTF8);

    /// append an array of integers as CSV

    procedure AddCSVInteger(const Integers: array of Integer); overload;

    /// append an array of doubles as CSV

    procedure AddCSVDouble(const Doubles: array of double); overload;

    /// append an array of RawUTF8 as CSV

    procedure AddCSVUTF8(const Values: array of RawUTF8); overload;

    /// append an array of const as CSV

    procedure AddCSVConst(const Values: array of const);

    /// write some data Base64 encoded

    // - if withMagic is TRUE, will write as '"\uFFF0base64encodedbinary"'

    procedure WrBase64(P: PAnsiChar; Len: cardinal; withMagic: boolean);

    /// write some record content as binary, Base64 encoded with our magic prefix

    procedure WrRecord(const Rec; TypeInfo: pointer);

    /// write some #0 ended UTF-8 text, according to the specified format

    procedure Add(P: PUTF8Char; Escape: TTextWriterKind); overload;

    /// write some #0 ended UTF-8 text, according to the specified format

    procedure Add(P: PUTF8Char; Len: PtrInt; Escape: TTextWriterKind); overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// write some #0 ended Unicode text as UTF-8, according to the specified format

    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,

    // CODEPAGE_US, or any version supported by the Operating System

    // - if codepage is 0, the current CurrentAnsiConvert.CodePage would be used

    // - will use TSynAnsiConvert to perform the conversion to UTF-8 

    procedure AddAnyAnsiBuffer(P: PAnsiChar; Len: integer;

      Escape: TTextWriterKind; CodePage: Integer);

    /// append some UTF-8 chars to the buffer

    // - input length is calculated from zero-ended char

    // - don't escapes chars according to the JSON RFC

    procedure AddNoJSONEscape(P: Pointer); overload;

    /// append some UTF-8 chars to the buffer

    // - don't escapes chars according to the JSON RFC

    procedure AddNoJSONEscape(P: Pointer; Len: integer); 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 chars, quoting all " chars

    // - same algorithm than AddString(QuotedStr()) - without memory allocation

    // - 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; TextLen: integer=0);

    /// append some chars, escaping all HTML special chars as expected

    procedure AddHtmlEscape(Text: PUTF8Char; Fmt: TTextWriterHTMLFormat=hfAnyWhere); overload;

    /// append some chars, escaping all HTML special chars as expected

    procedure AddHtmlEscape(Text: PUTF8Char; TextLen: integer;

      Fmt: TTextWriterHTMLFormat=hfAnyWhere); overload;

    /// append some chars, escaping all HTML special chars as expected

    procedure AddHtmlEscapeString(const Text: string;

      Fmt: TTextWriterHTMLFormat=hfAnyWhere);

    /// append some chars, escaping all HTML special chars as expected

    procedure AddHtmlEscapeUTF8(const Text: RawUTF8;

      Fmt: TTextWriterHTMLFormat=hfAnyWhere);

    /// convert some wiki-like text into proper HTML

    // - convert all #13#10 into <p>...</p>, *..* into <i>..</i> and +..+ into

    // <b>..</b>, then escape http:// as <a href=...> and any HTML special chars

    procedure AddHtmlEscapeWiki(P: PUTF8Char);

    /// append some chars, escaping all XML special chars as expected

    // - i.e.   < > & " '  as   &lt; &gt; &amp; &quote; &apos;

    // - 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 encode it

    // in big-endian order (most-signignifican byte first): use it for display

    // - up to 128 bytes may be converted

    procedure AddBinToHexDisplay(Bin: pointer; BinBytes: integer);

    /// add the pointer into hexa chars, ready to be displayed

    procedure AddPointer(P: PtrUInt);

    /// write a byte as hexa chars

    procedure AddByteToHex(Value: byte);

    /// write a Int18 value (0..262143) as 3 chars

    // - this encoding is faster than Base64, and has spaces on the left side

    // - use function Chars3ToInt18() to decode the textual content

    procedure AddInt18ToChars3(Value: cardinal);

    /// append some unicode chars to the buffer

    // - WideCharCount is the unicode chars count, not the byte size

    // - don't escapes chars according to the JSON RFC

    // - will convert the Unicode chars into UTF-8

    procedure AddNoJSONEscapeW(WideChar: PWord; WideCharCount: integer);

    /// append some UTF-8 encoded chars to the buffer

    // - if Len is 0, Len is calculated from zero-ended char

    // - escapes chars according to the JSON RFC

    procedure AddJSONEscape(P: Pointer; Len: PtrInt=0); overload;

    /// append some UTF-8 encoded chars to the buffer, from a generic string type

    // - faster than AddJSONEscape(pointer(StringToUTF8(string))

    // - escapes chars according to the JSON RFC

    procedure AddJSONEscapeString(const s: string);

      {$ifdef HASINLINE}inline;{$endif}

    /// append some UTF-8 encoded chars to the buffer, from the main AnsiString type

    // - escapes chars according to the JSON RFC

    procedure AddJSONEscapeAnsiString(const s: AnsiString);

    /// append some UTF-8 encoded chars to the buffer, from a generic string type

    // - faster than AddNoJSONEscape(pointer(StringToUTF8(string))

    // - don't escapes chars according to the JSON RFC

    // - will convert the Unicode chars into UTF-8

    procedure AddNoJSONEscapeString(const s: string);

      {$ifdef UNICODE}inline;{$endif}

    /// append some Unicode encoded chars to the buffer

    // - if Len is 0, Len is calculated from zero-ended widechar

    // - escapes chars according to the JSON RFC

    procedure AddJSONEscapeW(P: PWord; Len: PtrInt=0);

    /// append an open array constant value to the buffer

    // - "" will be added if necessary

    // - escapes chars according to the JSON RFC

    // - very fast (avoid most temporary storage)

    procedure AddJSONEscape(const V: TVarRec); overload;

    /// flush a supplied TTextWriter, and write pending data as JSON escaped text

    // - may be used with InternalJSONWriter, as a faster alternative to

    // ! AddJSONEscape(Pointer(fInternalJSONWriter.Text),0);

    procedure AddJSONEscape(Source: TTextWriter); overload;

    /// append 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); 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 cardinal values should be type-casted to Int64() (otherwise

    // the integer mapped value will be transmitted, therefore wrongly)

    // - 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  /<jRegex>/<jOptions>

    // 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(const aDynArray: TDynArray); overload;

    /// 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;

    {$ifdef UNDIRECTDYNARRAY}

    /// append a dynamic array content as UTF-8 encoded JSON array

    // - expect a dynamic array TDynArrayHashed wrapper as incoming parameter

    // - this method is needed by the fact that "object" is buggy under

    // newest versions of the Delphi compiler

    procedure AddDynArrayJSON(const aDynArray: TDynArrayHashed); overload; inline;

    {$endif}

    /// 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;

      Options: 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 is set in the instance Options

    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

    // - if EnumSetsAsText is FALSE, tkEnumeration and tkSet would be written as

    // integer numbers; if EnumSetsAsText is TRUE, they would be serialized as

    // a JSON string (for tkEnumeration) or JSON array of strings (for tkSet)

    // - if FullSetsAsStar is TRUE, a tkSet value containing all its items

    // would be serialized as the ["*"] JSON array  

    procedure AddTypedJSON(aTypeInfo: pointer; const aValue;

      EnumSetsAsText, FullSetsAsStar: boolean); 

    /// 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);

    /// 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; end;'

    // ! '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 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;

    /// 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;

      aTypeName: RawUTF8=''); overload;

    /// define a custom serialization for several simple types

    // - will call the overloaded RegisterCustomJSONSerializerFromTextSimpleType

    // method for each supplied type information

    class procedure RegisterCustomJSONSerializerFromTextSimpleType(

       const aTypeInfos: array of pointer); overload;

    /// undefine a custom serialization for a given dynamic array or record

    // - it will un-register any callback or text-based custom serialization

    // i.e. any previous RegisterCustomJSONSerializer() or

    // RegisterCustomJSONSerializerFromText() call

    // - expects TypeInfo() from a dynamic array or a record (will raise an

    // exception otherwise)

    // - it will set back to the default binary + Base64 encoding serialization

    class procedure UnRegisterCustomJSONSerializer(aTypeInfo: pointer);



    /// append some chars to the buffer in one line

    // - P should be ended with a #0

    // - will write #1..#31 chars as spaces (so content will stay on the same line)

    procedure AddOnSameLine(P: PUTF8Char); overload;

    /// append some chars to the buffer in one line

    // - will write #0..#31 chars as spaces (so content will stay on the same line)

    procedure AddOnSameLine(P: PUTF8Char; Len: PtrInt); overload;

    /// append some wide chars to the buffer in one line

    // - will write #0..#31 chars as spaces (so content will stay on the same line)

    procedure AddOnSameLineW(P: PWord; Len: PtrInt);



    /// return the last char appended

    function LastChar: AnsiChar;

    /// how many bytes are currently in the internal buffer and not on disk

    // - see TextLength for the total number of bytes, on both disk and memory

    function PendingBytes: PtrUInt;

      {$ifdef HASINLINE}inline;{$endif}

    /// how many bytes were currently written on disk

    // - excluding the bytes in the internal buffer

    // - see TextLength for the total number of bytes, on both disk and memory

    property WrittenBytes: cardinal read fTotalFileSize;

    /// the last char appended is canceled

    procedure CancelLastChar; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// the last char appended is canceled, if match the supplied one

    procedure CancelLastChar(aCharToCancel: AnsiChar); overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// the last char appended is canceled if it was a ','

    procedure CancelLastComma;

      {$ifdef HASINLINE}inline;{$endif}

    /// rewind the Stream to the position when Create() was called

    // - note that this does not clear the Stream content itself, just

    // move back its writing position to its initial place

    procedure CancelAll;



    /// count of added bytes to the stream

    // - see PendingBytes for the number of bytes currently in the memory buffer

    // or WrittenBytes for the number of bytes already written to disk

    property TextLength: cardinal read GetLength;

    /// define how AddEndOfLine method stores its line feed characters

    // - by default (FALSE), it will append a CR (#13) char to the buffer

    // - you can set this property to TRUE, so that CR+LF (#13#10) chars will

    // be appended instead

    // - is just a wrapper around twoEndOfLineCRLF item in CustomOptions

    property EndOfLineCRLF: boolean read GetEndOfLineCRLF write SetEndOfLineCRLF;

    /// allows to override default WriteObject property JSON serialization

    property OnWriteObject: TOnTextWriterObjectProp read fOnWriteObject write fOnWriteObject;

    /// the internal TStream used for storage

    // - you should call the FlushFinal (or FlushToStream) methods before using

    // this TStream content, to flush all pending characters

    // - if the TStream instance has not been specified when calling the

    // TTextWriter constructor, it can be forced via this property, before

    // any writting

    property Stream: TStream read fStream write SetStream;

    /// global options to customize this TTextWriter instance process

    // - allows to override e.g. AddRecordJSON() and AddDynArrayJSON() behavior

    property CustomOptions: TTextWriterOptions read fCustomOptions write fCustomOptions;

  end;



  /// simple writer to a Stream, specialized for the JSON format and SQL export

  // - use an internal buffer, faster than string+string

  TJSONWriter = class(TTextWriter)

  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); 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); 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 would 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

    procedure EndJSONObject(aKnownRowsCount,aRowsCount: integer);

      {$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

    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;



  /// 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)

  // - 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;

    procedure SetPassWordPlain(const Value: RawUTF8);

  public

    /// 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;

    /// this class method could be used to decrypt a password, stored as JSON,

    // according to a given private key

    class function ComputePlainPassword(const CypheredPassword: RawUTF8;

      CustomKey: cardinal=0): 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

    property PasswordPlain: RawUTF8 read GetPassWordPlain write SetPassWordPlain;

  end;



  /// 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;



/// 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;



{$ifndef NOVARIANTS}

/// will convert any TObject into a TDocVariant document instance

// - a 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

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))

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

procedure ObjectToVariant(Value: TObject; var result: variant;

  Options: TTextWriterWriteObjectOptions); overload;



{$endif}



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)

  TSynCache = class

  protected

    /// last index in fNameValue.List[] if was added by Find()

    // - contains -1 if no previous immediate call to Find()

    fFindLastAddedIndex: integer;

    /// store Key/Value pairs

    fNameValue: TSynNameValue;

    /// the global size of Values in cache, in bytes (to prevent memory burn)

    fValueSize: cardinal;

    /// the maximum RAM to be used for values, in bytes

    fMaxCacheRamUsed: cardinal;

  public

    /// initialize the internal storage

    // - aMaxCacheRamUsed can set the maximum RAM to be used for values, in bytes

    // (default is 16 MB per cache): cache will be reset when so much value

    // will be reached

    // - by default, key search is done case-insensitively, but you can specify

    // another option here

    constructor Create(aMaxCacheRamUsed: cardinal=16384*1024;

      aCaseSensitive: boolean=false);

    /// find a Key in the cache entries

    // - return '' if nothing found

    // - return the associated Value otherwise, and the associated integer tag

    // if aResultTag address is supplied

    function Find(const aKey: RawUTF8; aResultTag: PPtrInt): RawUTF8;

    /// add a Key and its associated value (and tag) to the cache entries

    // - you MUST always call Find() with the associated Key first

    procedure Add(const aValue: RawUTF8; aTag: PtrInt);

    /// 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

    function Reset: boolean;

    /// number of entries in the cache

    {$ifdef VER220} { circumvent Delphi XE compilation with packages }

    function Count: integer;

    {$else}

    property Count: integer read fNameValue.Count;

    {$endif}

  end;





  /// abstract ancestor to manage a dynamic array of TObject

  // - do not use this abstract class directly, but rather the inherited

  // TObjectListHashed and TObjectListPropertyHashed

  TObjectListHashedAbstract = class

  protected

    fList: TObjectDynArray;

    fCount: integer;

    fHash: TDynArrayHashed;

    fFreeItems: boolean;

    fHashValid: boolean;

    fHashed: boolean;

  public

    /// initialize the class instance

    // - if aFreeItems is TRUE (default), will behave like a TObjectList

    // - if aFreeItems is FALSE, will behave like a TList

    constructor Create(aFreeItems: boolean=true); reintroduce;

    /// release used memory

    destructor Destroy; override;

    /// search and add an object reference to the list

    // - returns the found/added index

    function Add(aObject: TObject; out wasAdded: boolean): integer; virtual; abstract;

    /// retrieve an object index within the list, using a fast hash table

    // - returns -1 if not found

    function IndexOf(aObject: TObject): integer; virtual; abstract;

    /// delete an object from the list

    procedure Delete(aIndex: integer); overload;

    /// delete an object from the list

    procedure Delete(aObject: TObject); overload;

    /// direct access to the items list array

    property List: TObjectDynArray read fList;

    /// returns the count of stored objects

    property Count: integer read fCount;

    /// direct access to the underlying hashing engine

    property Hash: TDynArrayHashed read fHash;

  end;



  /// this class behaves like TList/TObjectList, but will use hashing

  // for (much) faster IndexOf() method

  TObjectListHashed = class(TObjectListHashedAbstract)

  public

    /// search and add an object reference to the list

    // - returns the found/added index

    // - if added, hash is stored and Items[] := aObject

    function Add(aObject: TObject; out wasAdded: boolean): integer; override;

    /// retrieve an object index within the list, using a fast hash table

    // - returns -1 if not found

    function IndexOf(aObject: TObject): integer; override;

  end;



  /// function prototype used to retrieve the hashed property 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;

    procedure IntHashValid;

  public

    /// initialize the class instance with the corresponding callback in order

    // to handle sub-property hashing and search

    // - see TSetWeakZeroClass in mORMot.pas unit as example:

    // !  function WeakZeroClassSubProp(aObject: TObject): TObject;

    // !  begin

    // !    result := TSetWeakZeroInstance(aObject).fInstance;

    // !  end;

    // - by default, aHashElement/aCompare will hash/search for pointers:

    // you can specify the hash/search methods according to your sub property

    // (e.g. HashAnsiStringI/SortDynArrayAnsiStringI for a RawUTF8)

    // - if aFreeItems is TRUE (default), will behave like a TObjectList;

    // if aFreeItems is FALSE, will behave like a TList

    constructor Create(aSubPropAccess: TObjectListPropertyHashedAccessProp;

      aHashElement: TDynArrayHashOne=nil; aCompare: TDynArraySortCompare=nil;

      aFreeItems: boolean=true); reintroduce;

    /// search and add an object reference to the list

    // - returns the found/added index

    // - if added, only the hash is stored: caller has to set List[i]

    function Add(aObject: TObject; out wasAdded: boolean): integer; override;

    /// retrieve an object index within the list, using a fast hash table

    // - returns -1 if not found

    function IndexOf(aObject: TObject): integer; override;

  end;



  /// abstract class stored by a TPointerClassHash list

  TPointerClassHashed = class

  protected

    fInfo: pointer;

  public

    /// initialize the instance

    constructor Create(aInfo: pointer);

    /// the associated information of this instance

    // - may be e.g. a PTypeInfo value, when caching RTTI information

    property Info: pointer read fInfo write fInfo;

  end;

  /// a reference to a TPointerClassHashed instance

  PPointerClassHashed = ^TPointerClassHashed;



  /// handle a O(1) hashed-based storage of TPointerClassHashed, from a pointer

  // - used e.g. to store RTTI information from its PTypeInfo value

  // - if not thread safe, but could be used to store RTTI, since all type

  // information should have been initialized before actual process

  TPointerClassHash = class(TObjectListPropertyHashed)

  public

    /// initialize the storage list

    constructor Create;

    /// try to add an entry to the storage

    // - returns nil if the supplied information is already in the list

    // - returns a pointer to where a newly created TPointerClassHashed

    // instance should be stored

    // - this method is not thread-safe

    function TryAdd(aInfo: pointer): PPointerClassHashed;

    /// search for a stored instance, from its supplied pointer reference

    // - returns nil if aInfo was not previously added by FindOrAdd()

    // - this method is not thread-safe

    function Find(aInfo: pointer): TPointerClassHashed;

  end;



  /// handle a O(1) hashed-based storage of TPointerClassHashed, from a pointer

  // - this inherited class add a mutex to be thread-safe

  TPointerClassHashLocked = class(TPointerClassHash)

  protected

    fSafe: TSynLocker;

  public

    /// initialize the storage list

    constructor Create;

    /// finalize the storage list

    destructor Destroy; override;

    /// try to add an entry to the storage

    // - returns false if the supplied information is already in the list

    // - returns true, and a pointer to where a newly created TPointerClassHashed

    // instance should be stored: in this case, you should call UnLock once set

    // - could be used as such:

    // !var entry: PPointerClassHashed;

    // !...

    // !  if HashList.TryAddLocked(aTypeInfo,entry) then

    // !  try

    // !    entry^ := TMyCustomPointerClassHashed.Create(aTypeInfo,...);

    // !  finally

    // !    HashList.Unlock;

    // !  end;

    // !...

    function TryAddLocked(aInfo: pointer; out aNewEntry: PPointerClassHashed): boolean;

    /// release the lock after a previous TryAddLocked()=true call

    procedure Unlock;

    /// search for a stored instance, from its supplied pointer reference

    // - returns nil if aInfo was not previously added by FindOrAdd()

    // - this overriden method is thread-safe

    function FindLocked(aInfo: pointer): TPointerClassHashed;

  end;



  /// add locking methods to a standard TObjectList

  // - this class overrides the regular TObjectList, and do not share any code

  // with the TObjectListHashedAbstract/TObjectListHashed classes

  // - caller has to call the Lock/Unlock methods by hand to protect the

  // execution of regular TObjectList methods (like Add/Remove/Count...)

  TObjectListLocked = class(TObjectList)

  protected

    fSafe: TSynLocker;

  public

    /// initialize the list instance

    // - the stored TObject instances will be owned by this TObjectListLocked,

    // unless AOwnsObjects is set to false

    constructor Create(AOwnsObjects: Boolean=true); reintroduce;

    /// release the list instance (including the locking resource)

    destructor Destroy; override;

    /// the critical section associated to this list instance

    // - could be used to protect shared resources within the internal process

    // - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block

    property Safe: TSynLocker read fSafe;

  end;



  /// This class is able to emulate a TStringList with our native UTF-8 string type

  // - cross-compiler, from Delphi 6 and up, i.e is Unicode Ready for all

  TRawUTF8List = class

  protected

    fCount: PtrInt;

    fList: TRawUTF8DynArray;

    fObjects: TObjectDynArray;

    fObjectsOwned: boolean;

    fNameValueSep: AnsiChar;

    fCaseSensitive: boolean;

    fOnChange, fOnChangeHidden: TNotifyEvent;

    fOnChangeTrigerred: boolean;

    fOnChangeLevel: PtrInt;

    procedure Changed; virtual;

    procedure OnChangeHidden(Sender: TObject);

    procedure SetCapacity(const Value: PtrInt);

    function GetCapacity: PtrInt;

    procedure Put(Index: PtrInt; const Value: RawUTF8);

    function GetCount: PtrInt; {$ifdef HASINLINE}inline;{$endif}

    procedure PutObject(Index: PtrInt; const Value: TObject);

    function GetName(Index: PtrInt): RawUTF8;

    function GetValue(const Name: RawUTF8): RawUTF8;

    procedure SetValue(const Name, Value: RawUTF8);

    function GetTextCRLF: RawUTF8;

    procedure SetTextCRLF(const Value: RawUTF8);

    procedure SetTextPtr(P: PUTF8Char; const Delimiter: RawUTF8);

    function GetListPtr: PPUtf8CharArray;

    function GetObjectPtr: PPointerArray; {$ifdef HASINLINE}inline;{$endif}

    procedure SetCaseSensitive(Value: boolean); virtual;

  public

    /// initialize the class instance

    // - by default, any associated Objects[] are just weak references

    // - also define CaseSensitive=true

    // - you may supply aOwnObjects=true to force object instance management

    constructor Create(aOwnObjects: boolean=false);

    /// finalize the internal objects stored

    // - if instance was created with aOwnObjects=true

    destructor Destroy; override;

    /// get a stored RawUTF8 item

    // - returns '' and raise no exception in case of out of range supplied index

    function Get(Index: PtrInt): RawUTF8; {$ifdef HASINLINE}inline;{$endif}

    /// get a stored Object item by index

    // - returns nil and raise no exception in case of out of range supplied index

    function GetObject(Index: PtrInt): TObject; {$ifdef HASINLINE}inline;{$endif}

    /// get a stored Object item by name

    // - returns nil and raise no exception in case of out of range supplied index

    function GetObjectByName(const Name: RawUTF8): TObject;

    /// store a new RawUTF8 item

    // - returns -1 and raise no exception in case of self=nil

    function Add(const aText: RawUTF8): PtrInt; {$ifdef HASINLINE}inline;{$endif}

    /// store a new RawUTF8 item if not already in the list

    // - returns -1 and raise no exception in case of self=nil

    function AddIfNotExisting(const aText: RawUTF8; wasAdded: PBoolean=nil): PtrInt; virtual;

    /// store a new RawUTF8 item, and its associated TObject

    // - returns -1 and raise no exception in case of self=nil

    function AddObject(const aText: RawUTF8; aObject: TObject): PtrInt;

    /// store a new RawUTF8 item if not already in the list, and its associated TObject

    // - returns -1 and raise no exception in case of self=nil

    function AddObjectIfNotExisting(const aText: RawUTF8; aObject: TObject;

      wasAdded: PBoolean=nil): PtrInt; virtual;

    /// append a specified list to the current content

    procedure AddRawUTF8List(List: TRawUTF8List);

    /// delete a stored RawUTF8 item, and its associated TObject

    // - raise no exception in case of out of range supplied index

    procedure Delete(Index: PtrInt); overload; virtual;

    /// delete a stored RawUTF8 item, and its associated TObject

    // - will search for the value using IndexOf(aText), and returns its index

    // - returns -1 if no entry was found and deleted

    function Delete(const aText: RawUTF8): PtrInt; overload; virtual;

    /// delete a stored RawUTF8 item, and its associated TObject, from

    // a given Name when stored as 'Name=Value' pairs

    // - raise no exception in case of out of range supplied index

    function DeleteFromName(const Name: RawUTF8): PtrInt; virtual;

    /// update Value from an existing Name=Value, then optinally delete the entry

    procedure UpdateValue(const Name: RawUTF8; var Value: RawUTF8; ThenDelete: boolean);

    /// retrieve and delete the first RawUTF8 item in the list

    // - could be used as a FIFO

    function PopFirst(out aText: RawUTF8; aObject: PObject=nil): boolean; virtual;

    /// retrieve and delete the last RawUTF8 item in the list

    // - could be used as a FILO

    function PopLast(out aText: RawUTF8; aObject: PObject=nil): boolean; virtual;

    /// erase all stored RawUTF8 items

    // - and corresponding objects (if aOwnObjects was true at constructor)

    procedure Clear; virtual;

    /// find a RawUTF8 item in the stored Strings[] list

    // - this search is case sensitive if CaseSensitive property is TRUE (which

    // is the default)

    function IndexOf(const aText: RawUTF8): PtrInt; virtual;

    /// find the index of a given Name when stored as 'Name=Value' pairs

    // - search on Name is case-insensitive with 'Name=Value' pairs

    function IndexOfName(const Name: RawUTF8): PtrInt;

    /// find a TObject item index in the stored Objects[] list

    function IndexOfObject(aObject: TObject): PtrInt;

    /// access to the Value of a given 'Name=Value' pair

    function GetValueAt(Index: PtrInt): RawUTF8;

    /// retrieve the all lines, separated by the supplied delimiter

    function GetText(const Delimiter: RawUTF8=#13#10): RawUTF8;

    /// the OnChange event will be raised only when EndUpdate will be called

    procedure BeginUpdate;

    /// call the OnChange event if changes occured

    procedure EndUpdate;

    /// set all lines, separated by the supplied delimiter

    procedure SetText(const aText: RawUTF8; const Delimiter: RawUTF8=#13#10);

    /// set all lines from an UTF-8 text file

    // - expect the file is explicitly an UTF-8 file

    // - will ignore any trailing UTF-8 BOM in the file content, but will not

    // expect one either

    procedure LoadFromFile(const FileName: TFileName);

    /// write all lines into the supplied stream

    procedure SaveToStream(Dest: TStream; const Delimiter: RawUTF8=#13#10);

    /// write all lines into a new file

    procedure SaveToFile(const FileName: TFileName; const Delimiter: RawUTF8=#13#10);

    /// return the count of stored RawUTF8

    property Count: PtrInt read GetCount;

    /// set or retrive the current memory capacity of the RawUTF8 list

    property Capacity: PtrInt read GetCapacity write SetCapacity;

    /// get or set a RawUTF8 item

    // - returns '' and raise no exception in case of out of range supplied index

    // - if you want to use it with the VCL, use UTF8ToString() function

    property Strings[Index: PtrInt]: RawUTF8 read Get write Put; default;

    /// get or set a Object item

    // - returns nil and raise no exception in case of out of range supplied index

    property Objects[Index: PtrInt]: TObject read GetObject write PutObject;

    /// set if IndexOf() shall be case sensitive or not

    // - default is TRUE

    property CaseSensitive: boolean read fCaseSensitive write SetCaseSensitive;

    /// retrieve the corresponding Name when stored as 'Name=Value' pairs

    property Names[Index: PtrInt]: RawUTF8 read GetName;

    /// access to the corresponding 'Name=Value' pairs

    // - search on Name is case-insensitive with 'Name=Value' pairs

    property Values[const Name: RawUTF8]: RawUTF8 read GetValue write SetValue;

    /// the char separator between 'Name=Value' pairs

    // - equals '=' by default

    property NameValueSep: AnsiChar read fNameValueSep write fNameValueSep;

    /// set or retrieve all items as text lines

    // - lines are separated by #13#10 (CRLF) by default; use GetText and

    // SetText methods if you want to use another line delimiter (even a comma)

    property Text: RawUTF8 read GetTextCRLF write SetTextCRLF;

    /// Event triggered when an entry is modified

    property OnChange: TNotifyEvent read fOnChange write fOnChange;

    /// direct access to the memory of the RawUTF8 array

    property ListPtr: PPUtf8CharArray read GetListPtr;

    /// direct access to the memory of the Objects array

    property ObjectPtr: PPointerArray read GetObjectPtr;

  end;



  /// a TRawUTF8List with an associated lock for thread-safety

  TRawUTF8ListLocked = class(TRawUTF8List)

  protected

    fSafe: TSynLocker;

  public

    /// initialize the class instance

    constructor Create(aOwnObjects: boolean=false);

    /// finalize the instance

    // - and all internal objects stored, if was created with Create(true)

    destructor Destroy; override;

    /// access to the locking methods of this instance

    // - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block

    property Safe: TSynLocker read fSafe;

  end;



  /// a TRawUTF8List which will use an internal hash table for faster IndexOf()

  // - this is a rather rough implementation: all values are re-hashed after

  // change: but purpose of this class is to allow faster access of a static

  // list of identifiers (e.g. service method names) which are fixed during run

  TRawUTF8ListHashed = class(TRawUTF8List)

  protected

    fHash: TDynArrayHashed;

    fChanged: boolean;

    procedure SetCaseSensitive(Value: boolean); override;

    /// will set fChanged=true to force re-hash of all items

    procedure Changed; override;

  public

    /// initialize the class instance

    constructor Create(aOwnObjects: boolean=false);

    /// find a RawUTF8 item in the stored Strings[] list

    // - this overridden method will update the internal hash table (if needed),

    // then use it to retrieve the corresponding matching index

    // - if your purpose is to test if an item is existing, then add it on need,

    // use rather the AddObjectIfNotExisting() method which would preserve

    // the internal hash array, so would perform better

    function IndexOf(const aText: RawUTF8): PtrInt; override;

    /// store a new RawUTF8 item if not already in the list

    // - returns -1 and raise no exception in case of self=nil

    // - this overridden method will update and use the internal hash table,

    // so is preferred to plain Add if you want faster insertion

    // into the TRawUTF8ListHashed

    function AddIfNotExisting(const aText: RawUTF8; wasAdded: PBoolean=nil): PtrInt; override;

    /// store a new RawUTF8 item if not already in the list, and its associated TObject

    // - returns -1 and raise no exception in case of self=nil

    // - this overridden method will update and use the internal hash table,

    // so is preferred to plain Add if you want faster insertion

    // into the TRawUTF8ListHashed

    function AddObjectIfNotExisting(const aText: RawUTF8; aObject: TObject;

      wasAdded: PBoolean=nil): PtrInt; override;

    /// search in the low-level internal hashing table

    function HashFind(aHashCode: cardinal): integer; {$ifdef HASINLINE}inline;{$endif}

    /// access to the low-level internal hashing table

    property Hash: TDynArrayHashed read fHash;

  end;



  /// a TRawUTF8List with an internal hash, with locking methods

  // - by default, inherited methods are not protected by the mutex: you have

  // to explicitely call Lock/UnLock to enter or leave the critical section

  TRawUTF8ListHashedLocked = class(TRawUTF8ListHashed)

  protected

    fSafe: TSynLocker;

  public

    /// initialize the class instance

    constructor Create(aOwnObjects: boolean=false);

    /// finalize the instance

    // - and all internal objects stored, if was created with Create(true)

    destructor Destroy; override;

    /// access to the locking methods of this instance

    // - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block

    property Safe: TSynLocker read fSafe;

    /// add a RawUTF8 item in the stored Strings[] list

    // - just a wrapper over Add() using Safe.Lock/Unlock

    // - warning: this method WON'T update the internal hash array: use

    // AddIfNotExisting/AddObjectIfNotExisting() methods instead 

    function LockedAdd(const aText: RawUTF8): PtrInt; virtual; 

    /// find a RawUTF8 item in the stored Strings[] list

    // - just a wrapper over IndexOf() using Safe.Lock/Unlock

    function IndexOf(const aText: RawUTF8): PtrInt; override;

    /// find a RawUTF8 item in the stored Strings[] list

    // - just a wrapper over GetObjectByName() using Safe.Lock/Unlock

    // - warning: the object instance should remain in the list, so the caller

    // should not make any Delete/LockedDeleteFromName otherwise a GPF may occur

    function LockedGetObjectByName(const aText: RawUTF8): TObject; virtual;

    /// add a RawUTF8 item in the internal storage

    // - just a wrapper over AddIfNotExisting() using Safe.Lock/Unlock

    function AddIfNotExisting(const aText: RawUTF8; wasAdded: PBoolean=nil): PtrInt; override;

    /// add a RawUTF8 item in the internal storage, with an optional object

    // - just a wrapper over AddObjectIfNotExisting() using Safe.Lock/Unlock

    function AddObjectIfNotExisting(const aText: RawUTF8; aObject: TObject;

      wasAdded: PBoolean=nil): PtrInt; override;

    /// find and delete an RawUTF8 item in the stored Strings[] list

    // - just a wrapper over inherited Delete(aText) using Safe.Lock/Unlock

    function Delete(const aText: RawUTF8): PtrInt; override;

    /// find and delete an RawUTF8 item from its Name=... in the stored Strings[] list

    // - just a wrapper over inherited DeleteFromName() using Safe.Lock/Unlock

    function DeleteFromName(const Name: RawUTF8): PtrInt; override;

    /// retrieve and delete the first RawUTF8 item in the list

    // - could be used as a FIFO

    // - just a wrapper over inherited PopFirst() using Safe.Lock/Unlock

    function PopFirst(out aText: RawUTF8; aObject: PObject=nil): boolean; override;

    /// retrieve and delete the last RawUTF8 item in the list

    // - could be used as a FILO

    // - just a wrapper over inherited PopLast() using Safe.Lock/Unlock

    function PopLast(out aText: RawUTF8; aObject: PObject=nil): boolean; override;

    /// delete all RawUTF8 items in the list

    // - just a wrapper over inherited Clear using Safe.Lock/Unlock

    procedure Clear; override;

  end;



  /// This class is able to emulate a TStringList with our native UTF-8 string

  // type and storing TMethod callbacks

  // - cross-compiler, from Delphi 6 and up, i.e is Unicode Ready for all

  TRawUTF8MethodList = class(TRawUTF8ListHashed)

  protected

    fEvents: TMethodDynArray;

  public

    /// delete a stored RawUTF8 item, and its associated event

    // - raise no exception in case of out of range supplied index

    procedure Delete(Index: PtrInt); override;

    /// erase all stored RawUTF8 items and events

    procedure Clear; override;

    /// register a callback with its name

    function AddEvent(const aName: RawUTF8; const aEvent: TMethod): PtrInt;

    /// retrieve a callback from its index

    // - return FALSE if not previously set via AddEvent()

    // - return TRUE if found, and set aEvent to the corresponding callback

    function GetEvent(aIndex: PtrInt; out aEvent: TMethod): boolean;

    /// retrieve a callback from its hashed name

    // - return FALSE if not found

    // - return TRUE if found, and set aEvent to the corresponding callback

    function GetEventByName(const aText: RawUTF8; out aEvent: TMethod): boolean;

  end;



  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 loopp

  // - if the implementation method returns FALSE, will stop values browsing

  TSynDictionaryEvent = function(const aKey, aValue; aIndex,aCount: integer): boolean of object;



  /// thread-safe dictionary to store some values from associated keys

  // - will maintain a dynamic array of values, associated with a hashed dynamic

  // array for the keys, so that setting or retrieving values would be O(1)

  // - all process would be protected by a TSynLocker, so would 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(TSynPersistentLocked)

  protected

    fKeys: TDynArrayHashed;

    fValues: TDynArray;

    function InArray(const aKey,aArrayValue; aAction: TSynDictionaryInArray): boolean;

  public

    /// initialize the dictionary storage, for a given dynamic array value

    // - 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

    constructor Create(aKeyTypeInfo,aValueTypeInfo: pointer;

      aKeyCaseInsensitive: boolean=false); 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 would 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 would 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 would 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 would lock the instance

    function Delete(const aKey): 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

    function Find(const aKey): integer;

    /// 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

    function FindAndCopy(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 would lock the instance

    function ForEach(const OnEach: TSynDictionaryEvent): 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 would lock the instance

    function ForEach(const OnMatch: TSynDictionaryEvent;

      KeyCompare,ValueCompare: TDynArraySortCompare; const aKey,aValue): integer; overload;

    /// 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 would lock the instance

    function FindInArray(const aKey, aArrayValue): 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 would 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 would 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 would 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 would lock the instance

    function UpdateInArray(const aKey, aArrayValue): boolean;

    /// 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;

    /// unserialize the content from "key":value JSON object

    // - if the JSON input may not be correct (i.e. if not coming from SaveToJSON),

    // you may set EnsureNoKeyCollision=TRUE for a slow but safe keys validation

    function LoadFromJSON(const JSON: RawUTF8; EnsureNoKeyCollision: boolean=false): boolean; overload;

    /// unserialize the content from "key":value JSON object

    // - note that input JSON buffer is not modified in place: no need to create

    // a temporary copy if the buffer is about to be re-used

    // - if the JSON input may not be correct (i.e. if not coming from SaveToJSON),

    // you may set EnsureNoKeyCollision=TRUE for a slow but safe keys validation

    function LoadFromJSON(JSON: PUTF8Char; EnsureNoKeyCollision: boolean=false): boolean; overload;

    /// save the content as SynLZ-compressed raw binary data

    // - warning: this format is tied to the values low-level RTTI, so if you

    // change the value/key type definitions, LoadFromBinary() would fail

    function SaveToBinary: RawByteString;

    /// load the content from SynLZ-compressed raw binary data

    // - as previously saved by SaveToBinary method

    function LoadFromBinary(const binary: RawByteString): boolean;

    /// returns how many items are currently stored in this dictionary

    // - this method is thread-safe

    function Count: integer;

    /// 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;

  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;



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');



type

  /// handle memory mapping of a file content

  /// used to store and retrieve Words in a sorted array

  TMemoryMap = {$ifndef UNICODE}object{$else}record{$endif}

  private

    fBuf: PAnsiChar;

    fBufSize: cardinal;

    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: cardinal=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: cardinal); 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: cardinal read fBufSize;

  end;



  {$M+}

  /// able to read a UTF-8 text file using memory map

  // - much faster than TStringList.LoadFromFile()

  // - will ignore any trailing UTF-8 BOM in the file content, but will not

  // expect one either

  TMemoryMapText = class

  protected

    fLines: PPointerArray;

    fLinesMax: integer;

    fCount: integer;

    fMapEnd: PUTF8Char;

    fMap: TMemoryMap;

    fFileName: TFileName;

    fAppendedLines: TRawUTF8DynArray;

    fAppendedLinesCount: integer;

    function GetLine(aIndex: integer): RawUTF8; {$ifdef HASINLINE}inline;{$endif}

    function GetString(aIndex: integer): string; {$ifdef HASINLINE}inline;{$endif}

    /// call once by Create constructors when fMap has been initialized

    procedure LoadFromMap(AverageLineLength: integer=32); virtual;

    /// call once per line, from LoadFromMap method

    // - default implementation will set  fLines[fCount] := LineBeg;

    // - override this method to add some per-line process at loading: it will

    // avoid reading the entire file more than once

    procedure ProcessOneLine(LineBeg, LineEnd: PUTF8Char); virtual;

  public

    /// initialize the memory mapped text file

    // - this default implementation just do nothing but is called by overloaded

    // constructors so may be overriden to initialize an inherited class

    constructor Create; overload; virtual;

    /// read an UTF-8 encoded text file

    // - every line beginning is stored into LinePointers[]

    constructor Create(const aFileName: TFileName); overload;

    /// read an UTF-8 encoded text file content

    // - every line beginning is stored into LinePointers[]

    // - this overloaded constructor accept an existing memory buffer (some

    // uncompressed data e.g.)

    constructor Create(aFileContent: PUTF8Char; aFileSize: integer); overload;

    /// release the memory map and internal LinePointers[]

    destructor Destroy; override;

    /// save the whole content into a specified stream

    // - including any runtime appended values via AddInMemoryLine()

    procedure SaveToStream(Dest: TStream; const Header: RawUTF8);

    /// save the whole content into a specified file

    // - including any runtime appended values via AddInMemoryLine()

    // - an optional header text can be added to the beginning of the file

    procedure SaveToFile(FileName: TFileName; const Header: RawUTF8='');

    /// add a new line to the already parsed content

    // - this line won't be stored in the memory mapped file, but stay in memory

    // and appended to the existing lines, until this instance is released

    procedure AddInMemoryLine(const aNewLine: RawUTF8); virtual;

    /// clear all in-memory appended rows

    procedure AddInMemoryLinesClear; virtual;

    /// retrieve the number of UTF-8 chars of the given line

    // - warning: no range check is performed about supplied index

    function LineSize(aIndex: integer): integer;

      {$ifdef HASINLINE}inline;{$endif}

    /// check if there is at least a given number of UTF-8 chars in the given line

    // - this is faster than LineSize(aIndex)<aMinimalCount for big lines

    function LineSizeSmallerThan(aIndex, aMinimalCount: integer): boolean;

      {$ifdef HASINLINE}inline;{$endif}

    /// returns TRUE if the supplied text is contained in the corresponding line

    function LineContains(const aUpperSearch: RawUTF8; aIndex: Integer): Boolean; virtual;

    /// retrieve a line content as UTF-8

    // - a temporary UTF-8 string is created

    // - will return '' if aIndex is out of range

    property Lines[aIndex: integer]: RawUTF8 read GetLine;

    /// retrieve a line content as generic VCL string type

    // - a temporary VCL string is created (after conversion for UNICODE Delphi)

    // - will return '' if aIndex is out of range

    property Strings[aIndex: integer]: string read GetString;

    /// direct access to each text line

    // - use LineSize() method to retrieve line length, since end of line will

    // NOT end with #0, but with #13 or #10

    // - warning: no range check is performed about supplied index

    property LinePointers: PPointerArray read fLines;

    /// the memory map used to access the raw file content

    property Map: TMemoryMap read fMap;

  published

    /// the file name which was opened by this instance

    property FileName: TFileName read fFileName write fFileName;

    /// the number of text lines

    property Count: integer read fCount;

  end;

  {$M-}



  /// a fake TStream, which will just count the number of bytes written

  TFakeWriterStream = class(TStream)

  public

    function Read(var Buffer; Count: Longint): Longint; override;

    function Write(const Buffer; Count: Longint): Longint; override;

    function Seek(Offset: Longint; Origin: Word): Longint; override;

  end;



  /// a TStream using a RawByteString as internal storage

  // - default TStringStream uses WideChars since Delphi 2009, so it is

  // not compatible with previous versions, and it does make sense to

  // work with RawByteString in our UTF-8 oriented framework

  TRawByteStringStream = class(TStream)

  protected

    fDataString: RawByteString;

    fPosition: Integer;

    procedure SetSize(NewSize: Longint); override;

  public

    constructor Create(const aString: RawByteString=''); overload;

    function Read(var Buffer; Count: Longint): Longint; override;

    function Seek(Offset: Longint; Origin: Word): Longint; override;

    function Write(const Buffer; Count: Longint): Longint; override;

    property DataString: RawByteString read fDataString write fDataString;

  end;



  /// a TStream pointing to some 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: integer); overload;

    /// this TStream is read-only: calling this method will raise an exception

    function Write(const Buffer; Count: Longint): Longint; override;

  end;



  /// a TStream created from a file content, using fast memory mapping

  TSynMemoryStreamMapped = class(TSynMemoryStream)

  protected

    fMap: TMemoryMap;

    fFileStream: TFileStream;

    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: cardinal=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: cardinal=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;



  /// 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

  // - 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

  TFileBufferWriter = class

  private

    fPos: integer;

    fBufLen: Integer;

    fStream: TStream;

    fTotalWritten: Int64;

    fInternalStream: boolean;

    fTag: PtrInt;

    fBuf: RawByteString;

  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;

    /// release internal TStream (after AssignToHandle call)

    destructor Destroy; override;

    /// append some data at the current position

    procedure Write(Data: pointer; DataLen: integer); overload;

    /// append 1 byte of data at the current position

    procedure Write1(Data: Byte); {$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, then the string content, as expected

    // by the FromVarString() function

    procedure Write(const Text: RawByteString); overload;

    /// append some UTF-8 encoded text at the current position

    // - will write the string length, 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;

    {$endif}

    /// 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: integer; 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 UInt64 values using 64-bit variable length integer encoding

    // - if Offset is TRUE, then it will store the difference between

    // two values using 32-bit variable-length integer encoding (in this case,

    // a fixed-sized record storage is also handled separately)

    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 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 WriteDirectEnd

    function WriteDirectStart(maxSize: integer; const TooBigMessage: RawUTF8=''): PByte;

    /// finalize a direct write to a memory buffer

    // - by specifying the number of bytes written to the buffer

    procedure WriteDirectEnd(realSize: integer);

    /// 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;

    /// 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)

  // - 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 UNICODE}

  TFileBufferReader = record

  private

  {$else}

  TFileBufferReader = object

  protected

  {$endif}

    fCurrentPos: PtrUInt;

    fMap: TMemoryMap;

    /// get Isize + buffer from current memory map or fBufTemp into (P,PEnd)

    procedure ReadChunk(var 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, methods will use default slower file API

    procedure Open(aFile: THandle);

    /// initialize the buffer from an already existing memory block

    // - may be e.g. a resource or a TMemoryStream

    procedure OpenFrom(aBuffer: pointer; aBufferSize: cardinal); 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;

    /// 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: integer): 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

    function CurrentMemory: pointer;

    /// retrieve the current in-memory position

    // - if file was not memory-mapped, returns -1

    function CurrentPosition: integer;

    /// raise an exception in case of invalid content

    procedure ErrorInvalidContent;

    /// read-only access to the global file size

    property FileSize: Int64 read fMap.fFileSize;

    /// read-only access to the global mapped buffer binary

    property MappedBuffer: PAnsiChar read fMap.fBuf;

  end;





  /// 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(TSynPersistentLocked)

  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

    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;



/// FileSeek() overloaded function, working with huge files

// - Delphi FileSeek() is buggy -> use this function to safe access files > 2 GB

// (thanks to sanyin for the report)

function FileSeek64(Handle: THandle; const Offset: Int64; Origin: cardinal): Int64;





/// 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 cardinal values should be type-casted to Int64() (otherwise

// the integer mapped value will be transmitted, therefore wrongly)

// - 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  /<jRegex>/<jOptions>

// 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 cardinal values should be type-casted to Int64() (otherwise

// the integer mapped value will be transmitted, therefore wrongly)

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 cardinal values should be type-casted to Int64() (otherwise

// the integer mapped value will be transmitted, therefore wrongly)

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);



/// 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]^='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 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 PUTF8Char; var Values: TPUtf8CharDynArray;

  HandleValuesAsObjectOrArray: Boolean=false); overload;



/// wrapper to serialize a T*ObjArray dynamic array as JSON

// - as expected by TJSONSerializer.RegisterObjArrayForJSON()

function ObjArrayToJSON(const aObjArray;

  Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]): RawUTF8;



type

  /// store one name/value pair of raw UTF-8 content, from a JSON buffer

  // - used e.g. by JSONDecode() overloaded function to returns names/values

  TNameValuePUTF8Char = record

    Name: PUTF8Char;

    Value: PUTF8Char;

  end;

  /// used e.g. by JSONDecode() overloaded function to returns name/value pairs

  TNameValuePUTF8CharDynArray = array of TNameValuePUTF8Char;



/// 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 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

// - returns a pointer to the next content item in the JSON buffer

function JSONDecode(P: PUTF8Char; const Names: array of PUTF8Char;

  var Values: TPUtf8CharDynArray; HandleValuesAsObjectOrArray: Boolean=false): PUTF8Char; overload;



/// decode the supplied UTF-8 JSON content for the one supplied name

// - this function will decode the JSON content in-memory, so will unescape it

// in-place: it must be called only once with the same JSON data

function JSONDecode(var JSON: RawUTF8; const aName: RawUTF8='result';

  wasString: PBoolean=nil; HandleValuesAsObjectOrArray: Boolean=false): RawUTF8; overload;



/// retrieve a pointer to JSON string field content

// - returns either ':' for name field, either '}',',' for value field

// - returns nil on JSON content error

// - this function won't touch the JSON buffer, so you can call it before

// using in-place escape process via JSONDecode() or GetJSONField()

function JSONRetrieveStringField(P: PUTF8Char; out Field: PUTF8Char;

  out FieldLen: integer; ExpectNameField: boolean): PUTF8Char;

  {$ifdef HASINLINE}inline;{$endif}



/// decode a JSON field in an UTF-8 encoded buffer (used in TSQLTableJSON.Create)

// - this function decodes in the P^ buffer memory itself (no memory allocation

// or copy), for faster process - so take care that P^ is not shared

// - PDest points to the next field to be decoded, or nil on any unexpected end

// - optional wasString is set to true if the JSON value was a JSON "string"

// - null is decoded as nil, with wasString=false

// - true/false boolean values are returned as 'true'/'false', with wasString=false

// - '"strings"' are decoded as 'strings', with wasString=true, properly JSON

// unescaped (e.g. any \u0123 pattern would be converted into UTF-8 content)

// - any integer value is left as its ascii representation, with wasString=true

// - works for both field names or values (e.g. '"FieldName":' or 'Value,')

// - EndOfObject (if not nil) is set to the JSON value char (',' ':' or '}' e.g.)

function GetJSONField(P: PUTF8Char; out PDest: PUTF8Char;

  wasString: PBoolean=nil; EndOfObject: PUTF8Char=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): 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

// - PDest points to the next field to be decoded, or nil on any unexpected end

// - 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 '}')

function GetJSONFieldOrObjectOrArray(var P: PUTF8Char; wasString: PBoolean=nil;

  EndOfObject: PUTF8Char=nil; HandleValuesAsObjectOrArray: Boolean=false): 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);



/// test if the supplied buffer is a "string" value or a numerical value

// (floating point or integer), according to the characters within

// - this version will recognize null/false/true as strings

// - e.g. IsString('0')=false, IsString('abc')=true, IsString('null')=true

function IsString(P: PUTF8Char): boolean;



/// test if the supplied buffer is a "string" value or a numerical value

// (floating or integer), according to the JSON encoding schema

// - this version will NOT recognize JSON null/false/true as strings

// - e.g. IsStringJSON('0')=false, IsStringJSON('abc')=true,

// but IsStringJSON('null')=false

// - will follow the JSON definition of number, i.e. '0123' is a string (i.e.

// '0' is excluded at the begining of a number) and '123' is not a string

function IsStringJSON(P: PUTF8Char): boolean;



/// reach positon just after the current JSON item in the supplied UTF-8 buffer

// - buffer can be either any JSON item, i.e. a string, a number or even a

// JSON array (ending with ]) or a JSON object (ending with })

// - returns nil if the specified buffer is not valid JSON content

// - returns the position in buffer just after the item excluding the separator

// character - i.e. result^ may be ',','}',']'

function GotoEndJSONItem(P: PUTF8Char): PUTF8Char;



/// reach the positon of the next JSON item in the supplied UTF-8 buffer

// - buffer can be either any JSON item, i.e. a string, a number or even a

// JSON array (ending with ]) or a JSON object (ending with })

// - returns nil if the specified number of items is not available in buffer

// - returns the position in buffer after the item including the separator

// character (optionally in EndOfObject) - i.e. result will be at the start of

// the next object, and EndOfObject may be ',','}',']'

function GotoNextJSONItem(P: PUTF8Char; NumberOfItemsToJump: cardinal=1;

  EndOfObject: PAnsiChar=nil): PUTF8Char;



/// read the position of the JSON value just after a property identifier

// - this function will handle strict JSON property name (i.e. a "string"), but

// also MongoDB extended syntax, e.g. {age:{$gt:18}} or {'people.age':{$gt:18}}

// see @http://docs.mongodb.org/manual/reference/mongodb-extended-json

function GotoNextJSONPropName(P: PUTF8Char): PUTF8Char;



/// reach the position of the next JSON object of JSON array

// - first char is expected to be either '[' or '{' with default EndChar=#0

// - or you can 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=#0): PUTF8Char;



/// 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 ']')

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;



/// compute the number of fields in a JSON object

// - this will handle any kind of objects, including those with nested

// JSON objects or arrays

// - incoming P^ should point to the first char after the initial '{' (which

// may be a closing '}')

function JSONObjectPropCount(P: PUTF8Char): integer;



/// go to a named property of a JSON object

// - implemented via a fast SAX-like approach: the input buffer is not changed,

// nor no memory buffer allocated neither content copied

// - returns nil if the supplied property name does not exist

// - returns a pointer to the matching item in the JSON object

// - this will handle any kind of objects, including those with nested

// JSON objects or arrays

// - incoming P^ should point to the first initial '{' char

function JsonObjectItem(P: PUTF8Char; const PropName: RawUTF8;

  PropNameFound: PRawUTF8=nil): PUTF8Char;



/// go to a property of a JSON object, by its full path, e.g. 'parent.child'

// - implemented via a fast SAX-like approach: the input buffer is not changed,

// nor no memory buffer allocated neither content copied

// - returns nil if the supplied property path does not exist

// - returns a pointer to the matching item in the JSON object

// - this will handle any kind of objects, including those with nested

// JSON objects or arrays

// - incoming P^ should point to the first initial '{' char

function JsonObjectByPath(JsonObject,PropPath: PUTF8Char): PUTF8Char;



/// return all matching properties of a JSON object

// - here the PropPath could be a comma-separated list of full paths,

// e.g. 'Prop1,Prop2' or 'Obj1.Obj2.Prop1,Obj1.Prop2'

// - returns '' if no property did match

// - returns a JSON object of all matching properties

// - this will handle any kind of objects, including those with nested

// JSON objects or arrays

// - incoming P^ should point to the first initial '{' char

function JsonObjectsByPath(JsonObject,PropPath: PUTF8Char): RawUTF8;



/// convert one JSON object into two JSON arrays of keys and values

// - i.e. makes the following transformation:

// $ {key1:value1,key2,value2...} -> [key1,key2...] + [value1,value2...]

// - this function won't allocate any memory during its process, nor

// modify the JSON input buffer

// - is the reverse of the TTextWriter.AddJSONArraysAsJSONObject() method

function JSONObjectAsJSONArrays(JSON: PUTF8Char; out keys,values: RawUTF8): boolean;



/// remove comments from a text buffer before passing it to JSON parser

// - handle two types of comments: starting from // till end of line

// or /* ..... */ blocks anywhere in the text content

// - may be used to prepare configuration files before loading;

// for example we store server configuration in file config.json and

// put some comments in this file then code for loading is:

// !var cfg: RawUTF8;

// !  cfg := StringFromFile(ExtractFilePath(paramstr(0))+'Config.json');

// !  RemoveCommentsFromJSON(@cfg[1]);

// !  pLastChar := JSONToObject(sc,pointer(cfg),configValid);

procedure RemoveCommentsFromJSON(P: PUTF8Char);



const

  /// standard header for an UTF-8 encoded XML file

  XMLUTF8_HEADER = '<?xml version="1.0" encoding="UTF-8"?>'#13#10;



  /// standard namespace for a generic XML File

  XMLUTF8_NAMESPACE = '<contents xmlns="http://www.w3.org/2001/XMLSchema-instance">';



/// 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.

// '<contents xmlns="http://www.w3.org/2001/XMLSchema-instance">') - the

// corresponding ending token will be appended after (e.g. '</contents>')

// - 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. '<content>'

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}ptInt64{$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};







{ ************ filtering and validation classes and functions ************** }



/// 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;



/// return TRUE if the supplied content matchs to a grep-like 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'

// - initial C version by Kevin Boylan, first Delphi port by Sergey Seroukhov

function IsMatch(const Pattern, Text: RawUTF8; CaseInsensitive: boolean=false): 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;



  /// grep-like case-sensitive pattern validation of a Record field content

  // - parameter is NOT JSON encoded, but is some basic grep-like 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

  TSynValidatePattern = class(TSynValidate)

  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;



  /// grep-like case-insensitive pattern validation of a text field content

  // (typicaly a TSQLRecord)

  // - parameter is NOT JSON encoded, but is some basic grep-like 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;





{ ************ some other common types and conversion routines ************** }



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;

    /// 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)

  public

    /// constructor which will use FormatUTF8() instead of Format()

    // - expect % as delimitor, 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 the supplied variant

    constructor CreateUTF8(const Format: RawUTF8; const Args: array of const);

    {$ifndef NOEXCEPTIONINTERCEPT}

    /// can be used to customize how the exception is logged

    // - this default implementation will call the DefaultSynLogExceptionToStr()

    // function or the TSynLogExceptionToStrCustom global callback, if defined

    // - override this method to provide a custom logging content

    // - should return TRUE if Context.EAddr and Stack trace is not to be

    // written (i.e. as for any TSynLogExceptionToStr callback)

    function CustomLog(WR: TTextWriter; const Context: TSynLogExceptionContext): boolean; virtual;

    {$endif}

  published

    property Message;

  end;

  {$M-}

  ESynExceptionClass = class of ESynException;



  /// exception raised by all TSynTable related code

  ETableDataException = class(ESynException);



  /// exception class associated to TDocVariant JSON/BSON document

  EDocVariant = class(ESynException);



var

  /// allow to customize the ESynException logging message

  TSynLogExceptionToStrCustom: TSynLogExceptionToStr = nil;



  {$ifndef NOEXCEPTIONINTERCEPT}

  /// default exception logging callback - will be set by the SynLog unit

  // - will add the default Exception details, including any Exception.Message

  // - if the exception inherits from ESynException

  // - returns TRUE: caller will then append ' at EAddr' and the stack trace

  DefaultSynLogExceptionToStr: TSynLogExceptionToStr = nil;

  {$endif}





/// convert a string into its INTEGER Curr64 (value*10000) representation

// - this type is compatible with Delphi currency memory map with PInt64(@Curr)^

// - fast conversion, using only integer operations

// - if NoDecimal is defined, will be set to TRUE if there is no decimal, AND

// the returned value will be an Int64 (not a PInt64(@Curr)^)

function StrToCurr64(P: PUTF8Char; NoDecimal: PBoolean=nil): Int64;



/// convert a string into its currency representation

// - will call StrToCurr64()

function StrToCurrency(P: PUTF8Char): currency;



/// convert a currency value into a string

// - fast conversion, using only integer operations

// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals)

function CurrencyToStr(Value: currency): RawUTF8;



/// convert an INTEGER Curr64 (value*10000) into a string

// - this type is compatible with Delphi currency memory map with PInt64(@Curr)^

// - fast conversion, using only integer operations

// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals)

function Curr64ToStr(const Value: Int64): RawUTF8; overload;



/// convert an INTEGER Curr64 (value*10000) into a string

// - this type is compatible with Delphi currency memory map with PInt64(@Curr)^

// - fast conversion, using only integer operations

// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals)

procedure Curr64ToStr(const Value: Int64; var result: RawUTF8); overload;



/// convert an INTEGER Curr64 (value*10000) into a string

// - this type is compatible with Delphi currency memory map with PInt64(@Curr)^

// - fast conversion, using only integer operations

// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals)

// - return the number of chars written to Dest^

function Curr64ToPChar(const Value: Int64; Dest: PUTF8Char): PtrInt;



/// internal fast INTEGER Curr64 (value*10000) value to text conversion

// - expect the last available temporary char position in P

// - return the last written char position (write in reverse order in P^)

// - will return 0 for Value=0, or a string representation with always 4 decimals

//   (e.g. 1->'0.0001' 500->'0.0500' 25000->'2.5000' 30000->'3.0000')

// - is called by Curr64ToPChar() and Curr64ToStr() functions

function StrCurr64(P: PAnsiChar; const Value: Int64): PAnsiChar;

  {$ifdef HASINLINE}inline;{$endif}



/// 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;



/// 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;



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

  ConvertHexToBin: array[byte] of byte;



/// fast conversion from hexa chars into binary data

// - BinBytes contain the bytes count to be converted: Hex^ must contain

//  at least BinBytes*2 chars to be converted, and Bin^ enough space

// - if Bin=nil, no output data is written, but the Hex^ format is checked

// - return false if any invalid (non hexa) char is found in Hex^

// - using this function with Bin^ as an integer value will decode in big-endian

// order (most-signignifican byte first)

function HexToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: Integer): boolean; overload;



/// fast conversion from one hexa char pair into a 8 bit AnsiChar

// - return false if any invalid (non hexa) char is found in Hex^

// - similar to HexToBin(Hex,nil,1)

function HexToCharValid(Hex: PAnsiChar): boolean;

  {$ifdef HASINLINE}inline;{$endif}



/// fast 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 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 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 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 hexa chars into a pointer

function HexDisplayToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: integer): boolean;



/// fast conversion from hexa chars into a cardinal

// - reverse function of CardinalToHex()

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()

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 16-char hexadecimal

function HexDisplayToInt64(const Hex: RawByteString): Int64; overload;

  {$ifdef HASINLINE}inline;{$endif}





/// fast conversion from binary data into Base64 encoded UTF-8 text

function BinToBase64(const s: RawByteString): RawUTF8; overload;



/// fast conversion from binary data into Base64 encoded UTF-8 text

function BinToBase64(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload;



/// fast conversion from binary data into Base64-like URI-compatible encoded text

// - will trim any right-sided '=' unsignificant characters, and replace

// '+' or '/' by '_' or '-'

function BinToBase64URI(Bin: PAnsiChar; BinBytes: integer): RawUTF8;



/// conversion from any Base64 encoded value into URI-compatible encoded text

// - will trim any right-sided '=' unsignificant characters, and replace

// '+' or '/' by '_' or '-'

procedure Base64ToURI(var base64: RawUTF8);



/// conversion from URI-compatible encoded text into its original Base64 value

// - will add any right-sided '=' unsignificant characters, and replace back

// '_' or '-' by '+' or '/'

procedure Base64FromURI(var base64: RawUTF8);



/// 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 s: 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

function Base64ToBin(const s: RawByteString): RawByteString; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// fast conversion from Base64 encoded text into binary data

function Base64ToBin(sp: PAnsiChar; len: PtrInt): RawByteString; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// fast conversion from Base64 encoded text into binary data

procedure Base64ToBin(sp: PAnsiChar; len: PtrInt; var result: RawByteString); overload;



/// fast conversion from Base64 encoded text into binary data

procedure Base64ToBin(sp: PAnsiChar; len: PtrInt; var result: TSynTempBuffer); overload;



/// fast conversion from Base64 encoded text into binary data

// - returns TRUE on success, FALSE if base64 does not match binlen

// - if nofullcheck is FALSE, IsBase64() will be first called to validate the input

function Base64ToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt;

  nofullcheck: boolean=true): boolean; overload;



/// just a wrapper around Base64ToBin() for in-place decode of JSON_BASE64_MAGIC

// '\uFFF0base64encodedbinary' content into binary

// - input ParamValue shall have been checked to match the expected pattern

procedure Base64MagicDecode(var ParamValue: RawUTF8);



/// check and decode '\uFFF0base64encodedbinary' content into binary

// - this method will check the supplied value to match the expected

// JSON_BASE64_MAGIC pattern, decode and set Blob and return TRUE

function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: RawByteString): boolean; overload;



/// check and decode '\uFFF0base64encodedbinary' content into binary

// - this method will check the supplied value to match the expected

// JSON_BASE64_MAGIC pattern, decode and set Blob and return TRUE

function Base64MagicCheckAndDecode(Value: PUTF8Char; ValueLen: Integer;

  var Blob: RawByteString): boolean; overload;



/// check and decode '\uFFF0base64encodedbinary' content into binary

// - this method will check the supplied value to match the expected

// JSON_BASE64_MAGIC pattern, decode and set Blob and return TRUE

function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: TSynTempBuffer): boolean; overload;



/// check if the supplied text is a valid Base64 encoded stream

function IsBase64(const s: RawByteString): boolean; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// check if the supplied text is a valid Base64 encoded stream

function IsBase64(sp: PAnsiChar; len: PtrInt): boolean; overload;



/// retrieve the expected encoded length after Base64 process

function BinToBase64Length(len: PtrUInt): PtrUInt;

  {$ifdef HASINLINE}inline;{$endif}



/// retrieve the expected undecoded length of a Base64 encoded buffer

// - here len is the number 16 bytes in sp

function Base64ToBinLength(sp: PAnsiChar; len: PtrInt): PtrInt;



/// direct low-level decoding of a Base64 encoded buffer

// - here len is the number of 16 bytes chunks in sp

// - you should better not use this, but Base64ToBin() overloaded functions

procedure Base64Decode(sp,rp: PAnsiChar; len: PtrInt);



/// 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() method

function Chars3ToInt18(P: pointer): cardinal;

  {$ifdef HASINLINE}inline;{$endif}



/// 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)

// - 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): 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;



/// 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 ? instead of :(1234):

// - call internaly SQLParamContent() function for inline parameters decoding

// - 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;





/// add the 4 digits of integer Y to P^

procedure YearToPChar(Y: cardinal; P: PUTF8Char);

  {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif}



/// creates a 3 digits string from a 0..999 value

function UInt3DigitsToUTF8(Value: Cardinal): RawUTF8;

  {$ifdef HASINLINE}inline;{$endif}



/// creates a 4 digits string from a 0..9999 value

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

  Short4 = string[4];



/// creates a 4 digits short string from a 0..9999 value

// - using Short4 as returned string would avoid a string allocation on heap

// - could be used e.g. as parameter to FormatUTF8()

function UInt4DigitsToShort(Value: Cardinal): Short4;



/// creates a 3 digits short string from a 0..999 value

// - using Short4 as returned string would avoid a string allocation on heap

// - could be used e.g. as parameter to FormatUTF8()

function UInt3DigitsToShort(Value: Cardinal): Short4;



/// creates a 2 digits short string from a 0..99 value

// - using Short4 as returned string would avoid a string allocation on heap

// - could be used e.g. as parameter to FormatUTF8()

function UInt2DigitsToShort(Value: byte): Short4;



/// 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)<range

function SameValue(const A, B: Double; DoublePrec: double = 1E-12): Boolean;



/// 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)<range

function SameValueFloat(const A, B: TSynExtended; DoublePrec: TSynExtended = 1E-12): Boolean;



// our custom hash function, specialized for Text comparaison

// - has less colision than Adler32 for short strings

// - is faster than CRC32 or Adler32, since use DQWord (128 bytes) aligned read:

// Hash32() is 2.5 GB/s, kr32() 0.9 GB/s, crc32c() 1.7 GB/s or 3.7 GB/s (SSE4.2)

// - overloaded version for direct binary content hashing

function Hash32(Data: pointer; Len: integer): cardinal; overload;



// our custom hash function, specialized for Text comparaison

// - has less colision than Adler32 for short strings

// - is faster than CRC32 or Adler32, since use DQWord (128 bytes) aligned read

// - uses 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() 3.7 GB/s

function kr32(crc: cardinal; buf: PAnsiChar; len: cardinal): 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: cardinal): cardinal;



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

  crc32ctab: array[0..{$ifdef PUREPASCAL}3{$else}7{$endif},byte] of cardinal;



/// compute CRC32C checksum on the supplied buffer using x86/x64 code

// - result is compatible with SSE 4.2 based hardware accelerated instruction

// - result is not compatible with zlib's crc32() - not the same polynom

// - crc32cfast() is 1.7 GB/s, crc32csse42() is 3.7 GB/s

function crc32cfast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;



/// compute CRC64C checksum on the supplied buffer

// - 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

// - similar to crc64c, but with 63-bit, so no negative value, so 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

  /// store a 128-bit hash value

  // - e.g. a MD5 digest, or an AES block

  THash128 = array[0..15] of byte;

  /// store a 256-bit hash value

  // - e.g. a SHA-256 digest, or a TECCSignature result

  THash256 = array[0..31] of byte;



/// compute a 128-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 TAESBlock result

// - by design, such combined hashes cannot be cascaded

procedure crc128c(buf: PAnsiChar; len: cardinal; out crc: THash128);



/// 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} overload;



/// returns TRUE if all 16 bytes of both 128-bit buffers do match

// - e.g. a MD5 digest, or an AES block

function IsEqual(const A,B: THash128): boolean; overload;

  {$ifdef HASINLINE}inline;{$endif} overload;



/// 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;



/// 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 TDigest256 result

// - by design, such combined hashes cannot be cascaded

procedure crc256c(buf: PAnsiChar; len: cardinal; out crc: THash256);



/// 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} overload;



/// returns TRUE if all 32 bytes of both 256-bit buffers do match

// - e.g. a SHA-256 digest, or a TECCSignature result

function IsEqual(const A,B: THash256): boolean; overload;

  {$ifdef HASINLINE}inline;{$endif} overload;



/// 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;





type

  /// the potential features, retrieved from an Intel CPU

  // - see https://en.wikipedia.org/wiki/CPUID#EAX.3D1:_Processor_Info_and_Feature_Bits

  TIntelCpuFeature =

   ( { 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,

   { 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 in EBX, ECX }

   cfFSGS, cf_b01, cfSGX, cfBMI1, cfHLE, cfAVX2, cf_b06, cfSMEP, cfBMI2,

   cfERMS, cfINVPCID, cfRTM, cfPQM, cf_b13, cfMPX, cfPQE, cfAVX512F,

   cfAVX512DQ, cfRDSEED, cfADX, cfSMAP, cfAVX512IFMA, cfPCOMMIT,

   cfCLFLUSH, cfCLWB, cfIPT, cfAVX512PF, cfAVX512ER, cfAVX512CD,

   cfSHA, cfAVX512BW, cfAVX512VL, cfPREFW1, cfAVX512VBMI);



  /// 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 3.7 GB/s

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 (consider using SynCrypto instead)

procedure SymmetricEncrypt(key: cardinal; var data: RawByteString);



var

  /// compute CRC32C checksum on the supplied buffer

  // - this variable will use the fastest mean available, e.g. SSE 4.2

  // - you should use this function instead of crc32cfast() or crc32csse42()

  crc32c: THasher;



/// 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()

  // - is set to crc32c() function above by default

  DefaultHasher: THasher;



/// retrieve a particular bit status from a bit array

function GetBit(const Bits; aIndex: PtrInt): boolean;

  {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif}



/// set a particular bit into a bit array

procedure SetBit(var Bits; aIndex: PtrInt);

  {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif}



/// unset/clear a particular bit into a bit array

procedure UnSetBit(var Bits; aIndex: PtrInt);

  {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif}



/// compute the number of bits set in a bit array

// - Count is the bit count, not byte size

function GetBitsCount(const Bits; Count: PtrInt): integer;



const

  /// constant array used by GetAllBits() function (when inlined)

  ALLBITS_CARDINAL: array[1..32] of Cardinal = (

    1 shl 1-1, 1 shl 2-1, 1 shl 3-1, 1 shl 4-1, 1 shl 5-1, 1 shl 6-1,

    1 shl 7-1, 1 shl 8-1, 1 shl 9-1, 1 shl 10-1, 1 shl 11-1, 1 shl 12-1,

    1 shl 13-1, 1 shl 14-1, 1 shl 15-1, 1 shl 16-1, 1 shl 17-1, 1 shl 18-1,

    1 shl 19-1, 1 shl 20-1, 1 shl 21-1, 1 shl 22-1, 1 shl 23-1, 1 shl 24-1,

    1 shl 25-1, 1 shl 26-1, 1 shl 27-1, 1 shl 28-1, 1 shl 29-1, 1 shl 30-1,

    $7fffffff, $ffffffff);



/// returns TRUE if all BitCount bits are set in the input cardinal

function GetAllBits(Bits: Cardinal; BitCount: Integer): boolean;

  {$ifdef HASINLINE}inline;{$endif}



/// retrieve a particular bit status from a Int64 bit array (max aIndex is 63)

function GetBit64(const Bits; aIndex: PtrInt): boolean;

  {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif}



/// set a particular bit into a Int64 bit array (max aIndex is 63)

procedure SetBit64(var Bits: Int64; aIndex: PtrInt);

  {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif}



/// unset/clear a particular bit into a Int64 bit array (max aIndex is 63)

procedure UnSetBit64(var Bits: Int64; aIndex: PtrInt);

  {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif}



/// logical OR of two memory buffers

procedure OrMemory(Dest,Source: PByteArray; size: integer);

  {$ifdef HASINLINE}inline;{$endif}

  

/// logical XOR of two memory buffers

procedure XorMemory(Dest,Source: PByteArray; size: integer); overload;

  {$ifdef HASINLINE}inline;{$endif}



/// logical XOR of two memory buffers into a third

procedure XorMemory(Dest,Source1,Source2: PByteArray; size: integer); overload;

  {$ifdef HASINLINE}inline;{$endif}



/// logical AND of two memory buffers

procedure AndMemory(Dest,Source: PByteArray; size: integer);

  {$ifdef HASINLINE}inline;{$endif}



/// returns TRUE if all bytes equal zero

function IsZero(P: pointer; Length: integer): boolean; overload;



/// returns TRUE if Value is nil or all supplied Values[] equal ''

function IsZero(const Values: TRawUTF8DynArray): boolean; overload;



/// returns TRUE if Value is nil or all supplied Values[] equal 0

function IsZero(const Values: TIntegerDynArray): boolean; overload;



/// returns TRUE if Value is nil or all supplied Values[] equal 0

function IsZero(const Values: TInt64DynArray): boolean; overload;



/// 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}



/// 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;



/// 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}



/// name the current thread so that it would be easily identified in the IDE debugger

procedure SetCurrentThreadName(const Format: RawUTF8; const Args: array of const);



/// name a thread so that it would be easily identified in the IDE debugger

// - you can force this function to do nothing by setting the NOSETTHREADNAME

// conditional, if you have issues with this feature when debugging your app

procedure SetThreadName(ThreadID: TThreadID; const Format: RawUTF8;

  const Args: array of const);



/// could be used to override SetThreadNameInternal()

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;



  

{$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

    fPendingProcessLock: TRTLCriticalSection;

    fProcessEvent: TEvent;

    fOnBeforeExecute: TNotifyThreadEvent;

    fOnAfterExecute: TNotifyThreadEvent;

    fThreadName: RawUTF8;

    fExecuteFinished: 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

    constructor Create(const aThreadName: RawUTF8; OnBeforeExecute: TNotifyThreadEvent=nil;

      OnAfterExecute: TNotifyThreadEvent=nil); reintroduce;

    /// release used resources

    destructor Destroy; override;

    /// access to the low-level associated event used to notify task execution

    // to the background thread

    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

    fPendingProcessFlag: TSynBackgroundThreadProcessStep;

    fCallerEvent: TEvent;

    fParam: pointer;

    fCallerThreadID: TThreadID;

    fBackgroundException: Exception;

    fOnIdle: TOnIdleSynBackgroundThread;

    fOnBeforeProcess: TNotifyThreadEvent;

    fOnAfterProcess: TNotifyThreadEvent;

    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);

    /// 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;



  /// 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;



  /// an exception which would be raised by TSynParallelProcess

  ESynParallelProcess = class(ESynException);



  /// 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(TSynPersistentLocked)

  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 32 threads could be setup

    // - 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); 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

    procedure ParallelRunAndWait(Method: TSynParallelProcessMethod; MethodCount: integer);

  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;



{$endif LVCL} // LVCL does not implement TEvent





/// 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); 







{ ************ fast ISO-8601 types and conversion routines ***************** }



type

  /// fast bit-encoded date and time value

  // - faster than Iso-8601 text and TDateTime, e.g. can be used as published

  // property field in mORMot's TSQLRecord (see also TModTime and TCreateTime)

  // - use internally for computation an abstract "year" of 16 months of 32 days

  // of 32 hours of 64 minutes of 64 seconds - same as Iso8601ToTimeLog()

  // - use TimeLogFromDateTime/TimeLogToDateTime/TimeLogNow functions, or

  // type-cast any TTimeLog value with the TTimeLogBits memory structure for

  // direct access to its bit-oriented content (or via PTimeLogBits pointer)

  // - since TTimeLog type is bit-oriented, you can't just add or substract two

  // TTimeLog values when doing date/time computation: use a TDateTime temporary

  // conversion in such case:

  // ! aTimeStamp := TimeLogFromDateTime(IncDay(TimeLogToDateTime(aTimeStamp)));

  TTimeLog = type Int64;



  /// dynamic array of TTimeLog

  // - used by TDynArray JSON serialization to handle textual serialization

  TTimeLogDynArray = array of TTimeLog;



  /// pointer to a memory structure for direct access to a TTimeLog type value

  PTimeLogBits = ^TTimeLogBits;



  /// internal memory structure for direct access to a TTimeLog type value

  // - most of the time, you should not use this object, but higher level

  // TimeLogFromDateTime/TimeLogToDateTime/TimeLogNow/Iso8601ToTimeLog functions

  // - since TTimeLogBits.Value is bit-oriented, you can't just add or substract

  // two TTimeLog values when doing date/time computation: use a TDateTime

  // temporary conversion in such case

  // - TTimeLogBits.Value has a 38-bit precision, so features exact representation

  // as JavaScript numbers (stored in a 52-bit mantissa)

  TTimeLogBits = {$ifndef UNICODE}object{$else}record{$endif}

    /// the bit-encoded value itself, which follows an abstract "year" of 16

    // months of 32 days of 32 hours of 64 minutes of 64 seconds

    // - bits 0..5   = Seconds (0..59)

    // - bits 6..11  = Minutes (0..59)

    // - bits 12..16 = Hours   (0..23)

    // - bits 17..21 = Day-1   (0..31)

    // - bits 22..25 = Month-1 (0..11)

    // - bits 26..38 = Year    (0..4095)

    Value: Int64;

    /// extract the date and time content in Value into individual values

    procedure Expand(out Date: TSystemTime);

    /// convert to Iso-8601 encoded text

    function Text(Expanded: boolean; FirstTimeChar: AnsiChar = 'T'): RawUTF8; overload;

    /// convert to Iso-8601 encoded text

    function Text(Dest: PUTF8Char; Expanded: boolean;

      FirstTimeChar: AnsiChar = 'T'): integer; overload;

    /// convert to ready-to-be displayed text

    // - using i18nDateText global event, if set (e.g. by mORMoti18n.pas)

    function i18nText: string;

    /// convert to a Delphi Time

    function ToTime: TDateTime;

    /// convert to a Delphi Date

    // - will return 0 if the stored value is not a valid date

    function ToDate: TDateTime;

    /// convert to a Delphi Date and Time

    // - will return 0 if the stored value is not a valid date

    function ToDateTime: TDateTime;

    /// convert to a second-based c-encoded time (from Unix epoch 1/1/1970)

    function ToUnixTime: Int64;

    /// convert to a millisecond-based c-encoded time (from Unix epoch 1/1/1970)

    function ToUnixMSTime: Int64;

    /// fill Value from specified Date and Time

    procedure From(Y,M,D, HH,MM,SS: cardinal); overload;

    /// fill Value from specified TDateTime

    procedure From(DateTime: TDateTime; DateOnly: Boolean=false); overload;

    /// fill Value from specified File Date

    procedure From(FileDate: integer); overload;

    /// fill Value from Iso-8601 encoded text

    procedure From(P: PUTF8Char; L: integer); overload;

    /// fill Value from Iso-8601 encoded text

    procedure From(const S: RawUTF8); overload;

    /// fill Value from specified Date/Time individual fields

    procedure From(const Time: TSystemTime); overload;

    /// fill Value from second-based c-encoded time (from Unix epoch 1/1/1970)

    procedure FromUnixTime(const UnixTime: Int64);

    /// fill Value from millisecond-based c-encoded time (from Unix epoch 1/1/1970)

    procedure FromUnixMSTime(const UnixMSTime: Int64);

    /// 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(DateTime: TDateTime): 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; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// convert a Iso8601 encoded string into a TTimeLog value

// - handle TTimeLog bit-encoded Int64 format

// - use this function only for fast comparaison between two Iso8601 date/time

// - conversion is faster than Iso8601ToDateTime: use only binary integer math

// - ContainsNoTime optional pointer can be set to a boolean, which will be

// set according to the layout in P (e.g. TRUE for '2012-05-26')

// - returns 0 in case of invalid input string

function Iso8601ToTimeLogPUTF8Char(P: PUTF8Char; L: integer; ContainsNoTime: PBoolean=nil): TTimeLog;



/// convert a Iso8601 encoded string into a TTimeLog value

// - handle TTimeLog bit-encoded Int64 format

// - use this function only for fast comparaison between two Iso8601 date/time

// - conversion is faster than Iso8601ToDateTime: use only binary integer math

function Iso8601ToTimeLog(const S: RawByteString): TTimeLog;

  {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif}



/// 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;



/// 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

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

// - 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')

// - 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 only 'YYYY-MM-DDThh:mm:ss' or 'YYYY-MM-DD' or 'Thh:mm:ss'

// patterns, as e.g. generated by TTextWriter.AddDateTime() or RecordSaveJSON()

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

// - 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

// - 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)

// - handle 'hhmmss' and 'hh:mm:ss' format

// - if L is left to default 0, it will be computed from StrLen(P)

function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer; var H,M,S: cardinal): boolean; overload;



/// Interval date/time conversion from simple text

// - expected format does not match ISO-8601 Time intervals format, but Oracle

// interval litteral representation, i.e. '+/-D HH:MM:SS'

// - e.g. IntervalTextToDateTime('+0 06:03:20') will return 0.25231481481 and

// IntervalTextToDateTime('-20 06:03:20') -20.252314815

// - as a consequence, negative intervals will be written as TDateTime values:

// !DateTimeToIso8601Text(IntervalTextToDateTime('+0 06:03:20'))='T06:03:20'

// !DateTimeToIso8601Text(IntervalTextToDateTime('+1 06:03:20'))='1899-12-31T06:03:20'

// !DateTimeToIso8601Text(IntervalTextToDateTime('-2 06:03:20'))='1899-12-28T06:03:20'

function IntervalTextToDateTime(Text: PUTF8Char): TDateTime;

  {$ifdef HASINLINE}inline;{$endif}



/// Interval date/time conversion from simple text

// - expected format does not match ISO-8601 Time intervals format, but Oracle

// interval litteral representation, i.e. '+/-D HH:MM:SS'

// - e.g. '+1 06:03:20' will return 1.25231481481

procedure IntervalTextToDateTimeVar(Text: PUTF8Char; var result: TDateTime);



/// basic Date/Time conversion into ISO-8601

// - use 'YYYYMMDDThhmmss' format if not Expanded

// - use 'YYYY-MM-DDThh:mm:ss' format if Expanded

function DateTimeToIso8601(D: TDateTime; Expanded: boolean;

  FirstChar: AnsiChar='T'): RawUTF8;



/// basic Date conversion into ISO-8601

// - use 'YYYYMMDD' format if not Expanded

// - use 'YYYY-MM-DD' format if Expanded

function DateToIso8601(Date: TDateTime; Expanded: boolean): RawUTF8; overload;



/// basic Date conversion into ISO-8601

// - use 'YYYYMMDD' format if not Expanded

// - use 'YYYY-MM-DD' format if Expanded

function DateToIso8601(Y,M,D: cardinal; Expanded: boolean): RawUTF8; overload;



/// basic Time conversion into ISO-8601

// - use 'Thhmmss' format if not Expanded

// - use 'Thh:mm:ss' format if Expanded

function TimeToIso8601(Time: TDateTime; Expanded: boolean; FirstChar: AnsiChar='T'): RawUTF8;



/// Write a Date to P^ Ansi buffer

// - if Expanded is false, 'YYYYMMDD' date format is used

// - if Expanded is true, 'YYYY-MM-DD' date format is used

procedure DateToIso8601PChar(P: PUTF8Char; Expanded: boolean; Y,M,D: cardinal); overload;



/// convert a date into 'YYYY-MM-DD' date format

// - resulting text is compatible with all ISO-8601 functions

function DateToIso8601Text(Date: TDateTime): RawUTF8;



/// Write a Date/Time to P^ Ansi buffer

procedure DateToIso8601PChar(Date: TDateTime; P: PUTF8Char; Expanded: boolean); overload;



/// Write a TDateTime value, expanded as Iso-8601 encoded text into P^ Ansi buffer

// - if DT=0, returns ''

// - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD'

// - if DT contains only a time, returns the time encoded as 'Thh:mm:ss'

// - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss'

procedure DateTimeToIso8601ExpandedPChar(const Value: TDateTime; Dest: PUTF8Char;

  FirstChar: AnsiChar='T');



/// 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'

// - used e.g. by TPropInfo.GetValue() and TPropInfo.NormalizeValue() methods

function DateTimeToIso8601Text(DT: TDateTime; FirstChar: AnsiChar='T'): 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'

// - used e.g. by TPropInfo.GetValue() and TPropInfo.NormalizeValue() methods

procedure DateTimeToIso8601TextVar(DT: TDateTime; FirstChar: AnsiChar; var result: 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'

// - used e.g. by TPropInfo.GetValue() and TPropInfo.NormalizeValue() methods

procedure DateTimeToIso8601StringVar(DT: TDateTime; FirstChar: AnsiChar; var result: string);



/// 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

procedure TimeToIso8601PChar(P: PUTF8Char; Expanded: boolean; H,M,S: cardinal;

  FirstChar: AnsiChar = 'T'); 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

procedure TimeToIso8601PChar(Time: TDateTime; P: PUTF8Char; Expanded: boolean;

  FirstChar: AnsiChar = 'T'); overload;



/// fast conversion of 2 digit characters into a 0..99 value

// - returns FALSE on success, TRUE if P^ is not correct

function Char2ToByte(P: PUTF8Char; out Value: Cardinal): Boolean;



/// fast conversion of 3 digit characters into a 0..9999 value

// - returns FALSE on success, TRUE if P^ is not correct

function Char3ToWord(P: PUTF8Char; out Value: Cardinal): Boolean;



/// fast conversion of 4 digit characters into a 0..9999 value

// - returns FALSE on success, TRUE if P^ is not correct

function Char4ToWord(P: PUTF8Char; out Value: Cardinal): Boolean;



/// our own fast version of the corresponding low-level function

function TryEncodeDate(Year, Month, Day: Word; out Date: TDateTime): Boolean;



/// retrieve the current Date, in the ISO 8601 layout, but expanded and

// ready to be displayed

function NowToString(Expanded: boolean=true; FirstTimeChar: AnsiChar = ' '): RawUTF8;



/// retrieve the current UTC Date, in the ISO 8601 layout, but expanded and

// ready to be displayed

function NowUTCToString(Expanded: boolean=true; FirstTimeChar: AnsiChar = ' '): RawUTF8;



/// convert some date/time to the ISO 8601 text layout, including milliseconds

// - i.e. 'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format

function DateTimeMSToString(DateTime: TDateTime; Expanded: boolean=true;

  FirstTimeChar: AnsiChar = ' '; UTC: boolean=true): RawUTF8;



/// convert some date/time to the "HTTP-date" format as defined by RFC 7231

// - i.e. "Tue, 15 Nov 1994 12:45:26 GMT" to be used as a value of

// "Date", "Expires" or "Last-Modified" HTTP header

// - if you care about timezones Value must be converted to UTC first

// using TSynTimeZone.LocalToUtc

function DateTimeToHTTPDate(UTCDateTime: TDateTime): RawUTF8;



/// retrieve the current Time (whithout Date), in the ISO 8601 layout

// - useful for direct on screen logging e.g.

function TimeToString: RawUTF8;



/// convert a second-based c-encoded time (from Unix epoch 1/1/1970) as TDateTime

function UnixTimeToDateTime(const UnixTime: Int64): TDateTime;

  {$ifdef HASINLINE}inline;{$endif}



/// convert a TDateTime into a second-based c-encoded time (from Unix epoch 1/1/1970)

function DateTimeToUnixTime(const AValue: TDateTime): Int64;

  {$ifdef HASINLINE}inline;{$endif}



/// convert a millisecond-based c-encoded time (from Unix epoch 1/1/1970) as TDateTime

function UnixMSTimeToDateTime(const UnixTime: Int64): TDateTime;

  {$ifdef HASINLINE}inline;{$endif}



/// convert a TDateTime into a millisecond-based c-encoded time (from Unix epoch 1/1/1970)

function DateTimeToUnixMSTime(const AValue: TDateTime): Int64;

  {$ifdef HASINLINE}inline;{$endif}



/// returns the current UTC system date and time

// - SysUtils.Now returns local time: this function returns the system time

// expressed in Coordinated Universal Time (UTC)

function NowUTC: TDateTime;



type

  {$A-}

  /// used to store a Date/Time in TSynTimeZone internal structures

  // - map Windows.TSystemTime, since it is how it is stored in the Registry

  TTimeZoneValue = {$ifdef ISDELPHI2006ANDUP}record{$else}object{$endif}

    wYear: Word;

    wMonth: Word;

    wDayOfWeek: Word;

    wDay: Word;

    wHour: Word;

    wMinute: Word;

    wSecond: Word;

    wMilliseconds: Word;

    function IsZero: boolean;

      {$ifdef HASINLINE}inline;{$endif}

    function EncodeForTimeChange(const year: word): TDateTime;

  end;

  /// used to store Time Zone bias in TSynTimeZone

  // - map how low-level information is stored in the Windows Registry

  TTimeZoneInfo = record

    Bias: LongInt;

    bias_std: LongInt;

    bias_dlt: LongInt;

    change_time_std: TTimeZoneValue;

    change_time_dlt: TTimeZoneValue;

  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

  TTimeZoneData = {$ifdef ISDELPHI2006ANDUP}record{$else}object{$endif}

    id: TTimeZoneID;

    display: RawUTF8;

    tzi: TTimeZoneInfo;

    dyn: array of packed record

      year: integer;

      tzi: TTimeZoneInfo;

    end;

    function GetTziFor(year: integer): PTimeZoneInfo;

  end;

  /// used to store the Time Zone information of a TSynTimeZone class

  TTimeZoneDataDynArray = array of TTimeZoneData;

  {$A+}



  /// handle cross-platform time conversions, following Microsoft time zones 

  // - is able to retrieve accurate information from the Windows registry,

  // or from a binary compressed file on other platforms (which should have been

  // saved from a Windows system first) 

  // - each time zone will be idendified by its TzId string, as defined by

  // Microsoft for its Windows Operating system

  TSynTimeZone = class

  protected

    fZone: TTimeZoneDataDynArray;

    fZones: TDynArrayHashed;

    fLastZone: TTimeZoneID;

    fLastIndex: integer;

    fIds: TStringList;

    fDisplays: TStringList;

  public

    /// will retrieve the default shared TSynTimeZone instance

    // - locally created via the CreateDefault constructor

    // - this is the usual entry point for time zone process, calling e.g.

    // $ aLocalTime := TSynTimeZone.Default.NowToLocal(aTimeZoneID);

    class function Default: TSynTimeZone;

    /// initialize the internal storage

    // - but no data is available, until Load* methods are called

    constructor Create;

    /// retrieve the time zones from Windows registry, or from a local file

    // - under Linux, the file should be located with the executable, renamed

    // with a .tz extension - may have been created via SaveToFile(''), or

    // from a 'TSynTimeZone' bound resource

    // "dummy" parameter exists only to disambiguate constructors for C++

    constructor CreateDefault(dummy: integer=0);

    /// finalize the instance

    destructor Destroy; override;

    {$ifdef MSWINDOWS}

    {$ifndef LVCL}

    /// read time zone information from the Windows registry

    procedure LoadFromRegistry;

    {$endif}

    {$endif MSWINDOWS}

    /// read time zone information from a compressed file

    // - if no file name is supplied, a ExecutableName.tz file would be used

    procedure LoadFromFile(const FileName: TFileName='');

    /// read time zone information from a compressed memory buffer

    procedure LoadFromBuffer(const Buffer: RawByteString);

    /// read time zone information from a 'TSynTimeZone' resource

    // - the resource should contain the SaveToBuffer compressed binary content

    // - is no resource matching the TSynTimeZone class name and ResType=10

    // do exist, nothing would be loaded

    // - the resource could be created as such, from a Windows system:

    // ! TSynTimeZone.Default.SaveToFile('TSynTimeZone.data');

    // then compile the resource as expected, with a brcc32 .rc entry:

    // ! TSynTimeZone 10 "TSynTimeZone.data"

    procedure LoadFromResource;

    /// write then time zone information into a compressed file

    // - if no file name is supplied, a ExecutableName.tz file would be created

    procedure SaveToFile(const FileName: TFileName);

    /// write then time zone information into a compressed memory buffer

    function SaveToBuffer: RawByteString;

    /// retrieve the time bias (in minutes) for a given date/time on a TzId

    function GetBiasForDateTime(const Value: TDateTime; const TzId: TTimeZoneID;

      out Bias: integer; out HaveDaylight: boolean): boolean;

    /// retrieve the display text corresponding to a TzId

    // - returns '' if the supplied TzId is not recognized

    function GetDisplay(const TzId: TTimeZoneID): RawUTF8;

    /// compute the UTC date/time corrected for a given TzId

    function UtcToLocal(const UtcDateTime: TDateTime; const TzId: TTimeZoneID): TDateTime;

    /// compute the current date/time corrected for a given TzId

    function NowToLocal(const TzId: TTimeZoneID): TDateTime;

    /// compute the UTC date/time for a given local TzId value

    // - by definition, a local time may correspond to two UTC times, during the

    // time biais period, so the returned value is informative only, and any

    // stored value should be following UTC

    function LocalToUtc(const LocalDateTime: TDateTime; const TzID: TTimeZoneID): TDateTime;

    /// direct access to the low-level time zone information

    property Zone: TTimeZoneDataDynArray read fZone;

    /// direct access to the wrapper over the time zone information array

    property Zones: TDynArrayHashed read fZones;

    /// returns a TStringList of all TzID values

    // - could be used to fill any VCL component to select the time zone

    // - order in Ids[] array follows the Zone[].id information

    function Ids: TStrings;

    /// returns a TStringList of all Display text values

    // - could be used to fill any VCL component to select the time zone

    // - order in Displays[] array follows the Zone[].display information

    function Displays: TStrings;

  end;



var

  /// 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 by TTimeLogBits.i18nText and by TSQLTable.ExpandAsString() method,

  // i.e. TSQLTableToGrid.DrawCell()

  i18nDateText: function(Iso: TTimeLog): string = nil;





{$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;





/// 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);



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;





{ ************ fast low-level lookup types used by internal conversion routines }



{$ifndef ENHANCEDRTL}

{$ifndef LVCL} { don't define these const twice }



const

  /// fast lookup table for converting any decimal number from

  // 0 to 99 into their ASCII equivalence

  // - our enhanced SysUtils.pas (normal and LVCL) contains the same array

  TwoDigitLookup: packed array[0..99] of array[1..2] of AnsiChar =

    ('00','01','02','03','04','05','06','07','08','09',

     '10','11','12','13','14','15','16','17','18','19',

     '20','21','22','23','24','25','26','27','28','29',

     '30','31','32','33','34','35','36','37','38','39',

     '40','41','42','43','44','45','46','47','48','49',

     '50','51','52','53','54','55','56','57','58','59',

     '60','61','62','63','64','65','66','67','68','69',

     '70','71','72','73','74','75','76','77','78','79',

     '80','81','82','83','84','85','86','87','88','89',

     '90','91','92','93','94','95','96','97','98','99');



{$endif}

{$endif}



var

  /// fast lookup table for converting any decimal number from

  // 0 to 99 into their ASCII equivalence

  TwoDigitLookupW: packed array[0..99] of word absolute TwoDigitLookup;



const

  /// used internaly for fast word recognition (32 bytes const)

  IsWord: set of byte =

    [ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z')];



  /// used internaly for fast identifier recognition (32 bytes const)

  // - can be used e.g. for field or table name

  // - this char set matches the classical pascal definition of identifiers

  // - see also PropNameValid()

  IsIdentifier: set of byte =

    [ord('_'),ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z')];



  /// used internaly for fast URI "unreserved" characters identifier

  // - defined as unreserved  = ALPHA / DIGIT / "-" / "." / "_" / "~"

  // in @http://tools.ietf.org/html/rfc3986#section-2.3

  IsURIUnreserved: set of byte =

    [ord('a')..ord('z'),ord('A')..ord('Z'),ord('0')..ord('9'),

     ord('-'),ord('.'),ord('_'),ord('~')];



  /// used internaly for fast extended JSON property name recognition (32 bytes const)

  // - can be used e.g. for extended JSON object field

  // - follow JsonPropNameValid, GetJSONPropName and GotoNextJSONObjectOrArray

  IsJsonIdentifierFirstChar: set of byte =

    [ord('_'),ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z'),ord('$')];



  /// used internaly for fast extended JSON property name recognition (32 bytes const)

  // - can be used e.g. for extended JSON object field

  // - follow JsonPropNameValid, GetJSONPropName and GotoNextJSONObjectOrArray

  IsJsonIdentifier: set of byte =

    [ord('_'),ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z'),

     ord('.'),ord('['),ord(']')];



{$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;

    /// 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 bits 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;

    /// 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 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

    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;

  UnixDateDelta = 25569;



/// GetFileVersion returns the most significant 32 bits 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}



/// returns a JSON object containing basic information about the computer

// - including Host, User, CPU, OS, freemem, freedisk...

function SystemInfoJson: RawUTF8;



{$ifdef MSWINDOWS}



type

  /// the recognized Windows versions

  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);

  {$ifndef UNICODE}

  /// 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}



const

  /// the recognized Windows versions, as plain text

  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');



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)

  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;

  /// the current Operating System version, as retrieved for the current process

  // - contains e.g. 'Windows Seven 64 SP1 (6.1.7601)'

  OSVersionText: RawUTF8;



/// 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;



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

  GetTickCount64: function: Int64; stdcall;



/// similar to Windows sleep() API call, to be truly cross-platform

// - it should have a millisecond resolution, and handle ms=0 as a switch to

// another pending thread, i.e. under Windows will call SwitchToThread API

procedure SleepHiRes(ms: cardinal);



{$else MSWINDOWS}



var

  SystemInfo: record

    nprocs: integer;

    uts: UtsName;

  end;

  OSVersionText: RawUTF8;



{$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

// - will call the corresponding function in SynKylix.pas or SynFPCLinux.pas

function GetTickCount64: Int64;



{$endif MSWINDOWS}



/// overloaded function optimized for one pass file reading

// - will use e.g. the FILE_FLAG_SEQUENTIAL_SCAN flag under Windows, as stated

// by http://blogs.msdn.com/b/oldnewthing/archive/2012/01/20/10258690.aspx

// - is used e.g. by StringFromFile() and TSynMemoryStreamMapped.Create()

function FileOpenSequentialRead(const FileName: string): Integer;

  {$ifdef HASINLINE}inline;{$endif}



/// returns a TFileStream optimized for one pass file reading

// - will use FileOpenSequentialRead(), i.e. FILE_FLAG_SEQUENTIAL_SCAN

function FileStreamSequentialRead(const FileName: string): TFileStream;



/// check if the current timestamp, in ms, matched a given period

// - will compare the current GetTickCount64 to the supplied PreviousTix

// - returns TRUE if the Internal ms period was not elapsed

// - returns TRUE, and set PreviousTix, if the Interval ms period was elapsed

// - possible use case may be:

// !var Last: Int64;

// !...

// !  Last := GetTickCount64;

// !  repeat

// !    ...

// !    if Elapsed(Last,1000) then begin

// !      ... // do something every second

// !    end;

// !  until Terminated;

// !...

function Elapsed(var PreviousTix: Int64; Interval: Integer): Boolean;



{$ifndef FPC} { FPC defines those functions as built-in }



/// compatibility function, to be implemented according to the running CPU

// - expect the same result as the homonymous Win32 API function

function InterlockedIncrement(var I: Integer): Integer;

  {$ifdef PUREPASCAL}{$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif}{$endif}



/// compatibility function, to be implemented according to the running CPU

// - expect the same result as the homonymous Win32 API function

function InterlockedDecrement(var I: Integer): Integer;

  {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif}



{$endif FPC}



type

  /// stores some global information about the current executable and computer

  TExeVersion = record

    /// the main executable name, without any path nor extension

    // - e.g. 'Test' for 'c:\pathto\Test.exe'

    ProgramName: RawUTF8;

    /// the main executable details, as used e.g. by TSynLog

    // - e.g. 'C:\Dev\lib\SQLite3\exe\TestSQL3.exe 0.0.0.0 (2011-03-29 11:09:06)'

    ProgramFullSpec: RawUTF8;

    /// the main executable file name (including full path)

    // - same as paramstr(0)

    ProgramFileName: TFileName;

    /// the main executable full path (excluding .exe file name)

    // - same as ExtractFilePath(paramstr(0))

    ProgramFilePath: TFileName;

    /// the full path of the running executable or library

    // - for an executable, same as paramstr(0)

    // - for a library, will contain the whole .dll file name

    InstanceFileName: TFileName;

    /// the current executable version

    Version: TFileVersion;

    /// the current computer host name

    Host: RawUTF8;

    /// the current computer user name

    User: RawUTF8;

  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;



/// 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}



/// 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);





type

  /// to be used instead of TMemoryStream, for speed

  // - allocates memory from Delphi heap (i.e. FastMM4/SynScaleMM)

  // and not GlobalAlloc()

  // - uses bigger growing size of the capacity

{$ifdef LVCL} // LVCL already use Delphi heap instead of GlobalAlloc()

  THeapMemoryStream = TMemoryStream;

{$else}

  {$ifdef FPC} // FPC already use Delphi heap instead of GlobalAlloc()

  THeapMemoryStream = TMemoryStream;

  {$else}

  {$ifdef MSWINDOWS}

  THeapMemoryStream = class(TMemoryStream)

  protected

    function Realloc(var NewCapacity: longint): Pointer; override;

  end;

  {$else}

  THeapMemoryStream = TMemoryStream;

  {$endif}

  {$endif}

{$endif}



var

  /// a global "Garbage collector", for some classes instances which must

  // live during whole main executable process

  // - used to avoid any memory leak with e.g. 'class var RecordProps', i.e.

  // some singleton or static objects

  // - to be used, e.g. as:

  // !  Version := TFileVersion.Create(InstanceFileName,DefaultVersion32);

  // !  GarbageCollector.Add(Version);

  // - see also GarbageCollectorFreeAndNil() as an alternative

  GarbageCollector: TObjectList;



  /// set to TRUE when the global "Garbage collector" are beeing freed

  GarbageCollectorFreeing: boolean;



/// a global "Garbage collector" for some TObject global variables which must

// live during whole main executable process

// - this list expects a pointer to the TObject instance variable to be

// specified, and will be set to nil (like a FreeAndNil)

// - this may be useful when used when targetting Delphi IDE packages,

// to circumvent the bug of duplicated finalization of units, in the scope

// of global variables

// - to be used, e.g. as:

// !  if SynAnsiConvertList=nil then

// !    GarbageCollectorFreeAndNil(SynAnsiConvertList,TObjectList.Create);

procedure GarbageCollectorFreeAndNil(var InstanceVariable; Instance: TObject);



/// force the global "Garbage collector" list to be released immediately

// - this function is called in the finalization section of this unit

// - you should NEVER have to call this function, unless some specific cases

// (e.g. when using Delphi packages, just before releasing the package)

procedure GarbageCollectorFree;



/// enter a giant lock for thread-safe shared process

// - shall be protected as such:

// ! GlobalLock;

// ! try

// !   .... do something thread-safe but as short as possible

// ! finally

// !  GlobalUnLock;

// ! end;

// - you should better not use such a giant-lock, but an instance-dedicated

// critical section - these functions are just here to be convenient, for

// non time critical process

procedure GlobalLock;



/// release the giant lock for thread-safe shared process

// - you should better not use such a giant-lock, but an instance-dedicated

// critical section - these functions are just here to be convenient, for

// non time critical process

procedure GlobalUnLock;





{ ************ TSynTable generic 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

  /// 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);

  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;

    /// 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: 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

    procedure SelectFieldBits(var Fields: TSQLFieldBits; var withID: boolean);



    /// 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;

    /// 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;

    /// 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

    // - normaly, 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: TObjectList;

    /// all TSynValidate instances registered per each field

    Validates: TObjectList;

    /// 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);

    {$ifndef DELPHI5OROLDER}

    /// 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;

    {$endif DELPHI5OROLDER}

    /// 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 a GetIteraring(), because will use 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 UNICODE}

  TSynTableData = record

  private

  {$else}

  TSynTableData = object

  protected

  {$endif UNICODE}

    VType: TVarType;

    Filler: array[1..SizeOf(TVarData)-SizeOf(TVarType)-SizeOf(pointer)*2-4] of byte;

    VID: integer;

    VTable: TSynTable;

    VValue: TSBFString;

    {$ifndef NOVARIANTS}

    function GetFieldValue(const FieldName: RawUTF8): Variant; overload;

    procedure GetFieldVariant(const FieldName: RawUTF8; var result: Variant);

    procedure SetFieldValue(const FieldName: RawUTF8; const Value: Variant); overload;

    {$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 GetFieldValue write SetFieldValue;

    /// 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; overload;

    /// 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); overload;

      {$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 GetFieldIndexFromName(const aName: RawUTF8): integer;

    /// this method matchs the TSynTableFieldIndex event type

    function GetFieldIndexFromShortName(const aName: ShortString): integer;

    /// 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;



  /// SQL Query comparison operators

  // - these operators are e.g. used by CompareOperator() functions

  TCompareOperator = (

     soEqualTo,

     soNotEqualTo,

     soLessThan,

     soLessThanOrEqualTo,

     soGreaterThan,

     soGreaterThanOrEqualTo,

     soBeginWith,

     soContains,

     soSoundsLikeEnglish,

     soSoundsLikeFrench,

     soSoundsLikeSpanish);



/// 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;





/// JSON compatible representation of a boolean value

// - returns either 'true' or 'false'

procedure JSONBoolean(value: boolean; var result: RawUTF8);

  {$ifdef HASINLINE}inline;{$endif} overload;



const

  /// can be used e.g. in logs

  BOOL_STR: array[boolean] of string[7] = ('false','true');



  /// can be used to append to most English nouns to form a plural

  PLURAL_FORM: array[boolean] of RawUTF8 = ('','s');



  /// used by TSynTableStatement.WhereField for "SELECT .. FROM TableName WHERE ID=?"

  SYNTABLESTATEMENTWHEREID = 0;



/// convert any AnsiString content into our SBF compact binary format storage

procedure ToSBFStr(const Value: RawByteString; out Result: TSBFString);



/// returns TRUE if the specified field name is either 'ID', either 'ROWID'

function IsRowID(FieldName: PUTF8Char): boolean;

  {$ifdef HASINLINE}inline;{$endif} overload;



/// returns TRUE if the specified field name is either 'ID', either 'ROWID'

function IsRowID(FieldName: PUTF8Char; FieldLen: integer): boolean;

  {$ifdef HASINLINE}inline;{$endif} overload;



/// returns TRUE if the specified field name is either 'ID', either 'ROWID'

function IsRowIDShort(const FieldName: shortstring): boolean;

  {$ifdef HASINLINE}inline;{$endif} overload;



/// retrieve the next identifier within the UTF-8 buffer

// - returns true if something was set to Prop

function GetNextFieldProp(var P: PUTF8Char; var Prop: RawUTF8): boolean;





{ ************ variant-based process, including JSON/BSON document content }



const

  /// this variant type is not defined in older versions of Delphi

  varWord64 = 21;



  /// this variant type will map the current SynUnicode type

  // - depending on the compiler version

  varSynUnicode = {$ifdef HASVARUSTRING}varUString{$else}varOleStr{$endif};



  /// this variant type will map the current string type

  // - depending on the compiler version

  varNativeString = {$ifdef UNICODE}varUString{$else}varString{$endif};



  /// those TVarData.VType values are un-managed and do not need to be cleared

  // - used mainly in low-level code similar to the folllowing:

  // !  if TVarData(aVariant).VType and VTYPE_STATIC<>0 then

  // !    VarClear(aVariant);

  // - equals private constant varDeepData in Variants.pas 

  VTYPE_STATIC = $BFE8;



/// same as Dest := TVarData(Source) for simple values

// - will return TRUE for all simple values after varByRef unreference, and

// copying the unreferenced Source value into Dest raw storage

// - will return FALSE for not varByRef values, or complex values (e.g. string)

function SetVariantUnRefSimpleValue(const Source: variant; var Dest: TVarData): boolean;

  {$ifdef HASINLINE}inline;{$endif}



{$ifndef LVCL}



/// convert a raw binary buffer into a variant RawByteString varString

// - you can then use VariantToRawByteString() to retrieve the binary content

procedure RawByteStringToVariant(Data: PByte; DataLen: Integer; var Value: variant); overload;



/// convert a RawByteString content into a variant varString

// - you can then use VariantToRawByteString() to retrieve the binary content

procedure RawByteStringToVariant(const Data: RawByteString; var Value: variant); overload;



/// convert back a RawByteString from a variant

// - the supplied variant should have been created via a RawByteStringToVariant()

// function call

procedure VariantToRawByteString(const Value: variant; var Dest: RawByteString);



/// same as Value := Null, but slightly faster

procedure SetVariantNull(var Value: variant);

  {$ifdef HASINLINE}inline;{$endif}



const

  NullVarData: TVarData = (VType: varNull);

var

  /// a slightly faster alternative to Variants.Null function

  Null: variant absolute NullVarData;



{$endif}



/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster

// - we also discovered some issues with FPC's Variants unit, so this function

// may be used even in end-user cross-compiler code

function VarIsEmptyOrNull(const V: Variant): Boolean;

  {$ifdef HASINLINE}inline;{$endif}



/// same as VarIsEmpty(PVariant(V)^) or VarIsEmpty(PVariant(V)^), but faster

// - we also discovered some issues with FPC's Variants unit, so this function

// may be used even in end-user cross-compiler code

function VarDataIsEmptyOrNull(VarData: pointer): Boolean;

  {$ifdef HASINLINE}inline;{$endif}



/// fastcheck if a variant hold a value

// - varEmpty, varNull or a '' string would be considered as void

// - varBoolean=false or varDate=0 would be considered as void

// - a TDocVariantData with Count=0 would be considered as void 

// - any other value (e.g. integer) would be considered as not void  

function VarIsVoid(const V: Variant): boolean;



type

  TVarDataTypes = set of 0..255;



/// allow to check for a specific set of TVarData.VType

function VarIs(const V: Variant; const VTypes: TVarDataTypes): Boolean;

  {$ifdef HASINLINE}inline;{$endif}



{$ifndef NOVARIANTS}



type

  /// an abstract ancestor for faster access of properties

  // - default GetProperty/SetProperty methods are called via some protected

  // virtual IntGet/IntSet methods, with less overhead

  // - these kind of custom variants will be faster than the default

  // TInvokeableVariantType for properties getter/setter, but you should

  // manually register each type by calling SynRegisterCustomVariantType()

  // - also feature custom JSON parsing, via TryJSONToVariant() protected method

  TSynInvokeableVariantType = class(TInvokeableVariantType)

  protected

    {$ifndef FPC}

    {$ifndef DELPHI6OROLDER}

    /// our custom call backs do not want the function names to be uppercased

    function FixupIdent(const AText: string): string; override;

    {$endif}

    {$endif}

    /// override those two abstract methods for fast getter/setter implementation

    procedure IntGet(var Dest: TVarData; const V: TVarData; Name: PAnsiChar); virtual; abstract;

    procedure IntSet(const V, Value: TVarData; Name: PAnsiChar); virtual; abstract;

  public

    /// customization of JSON parsing into variants

    // - will be called by e.g. by VariantLoadJSON() or GetVariantFromJSON()

    // with Options: PDocVariantOptions parameter not nil

    // - this default implementation will always returns FALSE,

    // meaning that the supplied JSON is not to be handled by this custom

    // (abstract) variant type

    // - this method could be overridden to identify any custom JSON content

    // and convert it into a dedicated variant instance, then return TRUE

    // - warning: should NOT modify JSON buffer in-place, unless it returns true

    function TryJSONToVariant(var JSON: PUTF8Char; var Value: variant;

      EndOfObject: PUTF8Char): boolean; virtual;

    /// customization of variant into JSON serialization

    procedure ToJSON(W: TTextWriter; const Value: variant; Escape: TTextWriterKind); overload; virtual;

    /// retrieve the field/column value

    // - this method will call protected IntGet abstract method

    function GetProperty(var Dest: TVarData; const V: TVarData;

      const Name: String): Boolean; override;

    /// set the field/column value

    // - this method will call protected IntSet abstract method

    {$ifdef FPC_VARIANTSETVAR} // see http://mantis.freepascal.org/view.php?id=26773

    function SetProperty(var V: TVarData; const Name: string;

      const Value: TVarData): Boolean; override;

    {$else}

    function SetProperty(const V: TVarData; const Name: string;

      const Value: TVarData): Boolean; override;

    {$endif}

    /// clear the content

    // - this default implementation will set VType := varEmpty

    // - override it if your custom type needs to manage its internal memory

    procedure Clear(var V: TVarData); override;

    /// copy two variant content

    // - this default implementation will copy the TVarData memory

    // - override it if your custom type needs to manage its internal structure

    procedure Copy(var Dest: TVarData; const Source: TVarData;

      const Indirect: Boolean); override;

    /// copy two variant content by value

    // - this default implementation will call the Copy() method

    // - override it if your custom types may use a by reference copy pattern

    procedure CopyByValue(var Dest: TVarData; const Source: TVarData); virtual;

    /// this method will allow to look for dotted name spaces, e.g. 'parent.child'

    // - should return Unassigned if the FullName does not match any value

    // - this default implementation will handle TDocVariant storage, or using

    // generic TSynInvokeableVariantType.IntGet() until nested value match

    // - you can override it with a more optimized version

    procedure Lookup(var Dest: TVarData; const V: TVarData; FullName: PUTF8Char); virtual;

    /// will check if the value is an array, and return the number of items

    // - if the document is an array, will return the items count (0 meaning

    // void array)

    // - this default implementation will return -1 (meaning this is not an array)

    // - overridden method could implement it, e.g. for TDocVariant of kind dvArray

    function IterateCount(const V: TVarData): integer; virtual;

    /// allow to loop over an array value

    // - Index should be in 0..IterateCount-1 range

    // - this default implementation will do nothing

    procedure Iterate(var Dest: TVarData; const V: TVarData; Index: integer); virtual;

    /// returns TRUE if the supplied variant is of the exact custom type

    function IsOfType(const V: variant): boolean;

  end;



  /// 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

    procedure IntGet(var Dest: TVarData; const V: TVarData; Name: PAnsiChar); override;

    procedure IntSet(const V, Value: TVarData; Name: PAnsiChar); 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;



  /// class-reference type (metaclass) of custom variant type definition

  // - used by SynRegisterCustomVariantType() function

  TSynInvokeableVariantTypeClass = class of TSynInvokeableVariantType;



/// register a custom variant type to handle properties

// - this will implement an internal mechanism used to bypass the default

// _DispInvoke() implementation in Variant.pas, to use a faster version

// - is called in case of TSynTableVariant, TDocVariant, TBSONVariant or

// TSQLDBRowVariant

function SynRegisterCustomVariantType(aClass: TSynInvokeableVariantTypeClass): TSynInvokeableVariantType;





type

  /// possible options for a TDocVariant JSON/BSON document storage

  // - 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)

  // - dvoReturnNullForOutOfRangeIndex  will be used when retrieving any value

  // from its 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

  TDocVariantOption =

    (dvoNameCaseSensitive, dvoCheckForDuplicatedNames,

     dvoReturnNullForUnknownProperty, dvoReturnNullForOutOfRangeIndex,

     dvoValueCopiedByReference, dvoJSONParseDoNotTryCustomVariants,

     dvoJSONObjectParseWithinString, dvoSerializeAsExtendedJson);



  /// 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]

  TDocVariantOptions = set of TDocVariantOption;



  /// pointer to a set of options for a TDocVariant storage

  PDocVariantOptions = ^TDocVariantOptions;



const

  /// some convenient TDocVariant options

  // - JSON_OPTIONS[false] is e.g. _Json() and _JsonFmt() functions default

  // - JSON_OPTIONS[true] are used e.g. by _JsonFast() and _JsonFastFmt() functions

  JSON_OPTIONS: array[Boolean] of TDocVariantOptions = (

    [dvoReturnNullForUnknownProperty],

    [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference]);



  /// same as JSON_OPTIONS[true], but can not be used as PDocVariantOptions

  JSON_OPTIONS_FAST =

    [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference];



  /// TDocVariant options which may be used for plain JSON parsing

  // - this won't recognize any extended syntax

  JSON_OPTIONS_FAST_STRICTJSON: TDocVariantOptions =

    [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference,

     dvoJSONParseDoNotTryCustomVariants];



  /// TDocVariant options to be used for case-sensitive TSynNameValue-like

  // storage, with optional extended JSON syntax serialization

  JSON_OPTIONS_NAMEVALUE: array[boolean] of TDocVariantOptions = (

    [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference,

     dvoNameCaseSensitive],

    [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference,

     dvoNameCaseSensitive,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 TSynNameValue-like storage

  JSON_OPTIONS_FAST_EXTENDED: TDocVariantOptions =

    [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference,

     dvoSerializeAsExtendedJson];





/// 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}



/// 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 (i.e. the RecordLoad/RecordSave layout)

// - warning: will encode generic string fields as within the variant type

// itself: using this function between UNICODE and NOT UNICODE

// versions of Delphi, will propably fail - you have been warned!

function VariantSave(const Value: variant; Dest: PAnsiChar): PAnsiChar; overload;



/// save a Variant content into a binary buffer

// - will handle standard Variant types and custom types (serialized as JSON)

// - will return '' in case of an invalid (not handled) Variant type

// - just a wrapper around VariantSaveLength()+VariantSave()

// - warning: will encode generic string fields as within the variant type

// itself: using this function between UNICODE and NOT UNICODE

// versions of Delphi, will propably fail - you have been warned!

function VariantSave(const Value: variant): RawByteString; overload;



/// retrieve a variant value from our optimized binary serialization format

// - follow the data layout as used by RecordLoad() or VariantSave() function

// - return nil if the Source buffer is incorrect

// - in case of success, return the memory buffer pointer just after the

// read content

// - how custom type variants are created can be defined via CustomVariantOptions

function VariantLoad(var Value: variant; Source: PAnsiChar;

  CustomVariantOptions: PDocVariantOptions): PAnsiChar; overload;



/// retrieve a variant value from our optimized binary serialization format

// - follow the data layout as used by RecordLoad() or VariantSave() function

// - return varEmpty if the Source buffer is incorrect

// - just a wrapper around VariantLoad()

// - how custom type variants are created can be defined via CustomVariantOptions

function VariantLoad(const Bin: RawByteString;

  CustomVariantOptions: PDocVariantOptions): variant; overload;



/// retrieve a variant value from a JSON number or string

// - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON)

// - will instantiate either an Integer, Int64, currency, double or string value

// (as RawUTF8), guessing the best numeric type according to the textual content,

// and string in all other cases, except TryCustomVariants points to some options

// (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or

// array, either encoded as strict-JSON (i.e. {..} or [..]), or with some

// extended (e.g. BSON) syntax

// - warning: the JSON buffer will be modified in-place during process - use

// a temporary copy or the overloaded functions with RawUTF8 parameter

// if you need to access it later

function VariantLoadJSON(var Value: variant; JSON: PUTF8Char;

  EndOfObject: PUTF8Char=nil; TryCustomVariants: PDocVariantOptions=nil): 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); 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): 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 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

procedure GetVariantFromJSON(JSON: PUTF8Char; wasString: Boolean; var Value: variant;

  TryCustomVariants: PDocVariantOptions=nil);



/// identify either varInt64, varDouble, varCurrency types following JSON format

// - any non valid number is returned as varString

// - is used e.g. by GetVariantFromJSON() to guess the destination variant type

// - warning: supplied JSON is expected to be not nil

function TextToVariantNumberType(JSON: PUTF8Char): word;



/// low-level function to set a numerical variant from an unescaped JSON number

// - returns TRUE if TextToVariantNumberType(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): boolean;



/// 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;



/// convert an UTF-8 encoded text buffer into a variant RawUTF8 varString

// - this overloaded version expects a destination variant type (e.g. varString

// varOleStr / varUString) - if the type is not handled, will raise an

// EVariantTypeCastError

procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: TVarData;

  ExpectedValueType: word); overload;



/// convert an open array (const Args: array of const) argument to a variant

// - note that cardinal values should be type-casted to Int64() (otherwise

// the integer mapped value will be transmitted, therefore wrongly)

procedure VarRecToVariant(const V: TVarRec; var result: variant); overload;



/// convert an open array (const Args: array of const) argument to a variant

// - note that cardinal values should be type-casted to Int64() (otherwise

// the integer mapped value will be transmitted, therefore wrongly)

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 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);



/// 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;



/// guess the correct TSQLDBFieldType from a variant value

function VariantTypeToSQLDBFieldType(const V: Variant): TSQLDBFieldType;



var

  /// the internal custom variant type used to register TDocVariant

  DocVariantType: TSynInvokeableVariantType = nil;

  /// copy of DocVariantType.VarType

  // - as used by inlined functions of TDocVariantData

  DocVariantVType: integer;





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

    /// fast getter/setter implementation

    procedure IntGet(var Dest: TVarData; const V: TVarData; Name: PAnsiChar); override;

    procedure IntSet(const V, Value: TVarData; Name: PAnsiChar); override;

  public

    /// initialize a variant instance to store some document-based content

    // - by default, every internal value will be copied, so access of nested

    // properties can be slow - if you expect the data to be read-only or not

    // propagated into another place, set aOptions=[dvoValueCopiedByReference]

    // will increase the process speed a lot

    class procedure New(out aValue: variant;

      aOptions: TDocVariantOptions=[]); overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// initialize a variant instance to store per-reference document-based content

    // - same as New(aValue,JSON_OPTIONS[true]);

    // - to be used e.g. as

    // !var v: variant;

    // !begin

    // !  TDocVariant.NewFast(v);

    // !  ...

    class procedure NewFast(out aValue: variant); overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// ensure a variant is a TDocVariant instance

    // - if aValue is not a TDocVariant, will create a new JSON_OPTIONS[true]

    class procedure IsOfTypeOrNewFast(var aValue: variant);

    /// initialize several variant instances to store document-based content

    // - replace several calls to TDocVariantData.InitFast

    // - to be used e.g. as

    // !var v1,v2,v3: TDocVariantData;

    // !begin

    // !  TDocVariant.NewFast([@v1,@v2,@v3]);

    // !  ...

    class procedure NewFast(const aValues: array of PDocVariantData); overload;

    /// initialize a variant instance to store some document-based content

    // - you can use this function to create a variant, which can be nested into

    // another document, e.g.:

    // ! aVariant := TDocVariant.New;

    // ! aVariant.id := 10;

    // - by default, every internal value will be copied, so access of nested

    // properties can be slow - if you expect the data to be read-only or not

    // propagated into another place, set Options=[dvoValueCopiedByReference]

    // will increase the process speed a lot

    // - in practice, you should better use _Obj()/_ObjFast() _Arr()/_ArrFast()

    // functions or TDocVariant.NewFast()

    class function New(Options: TDocVariantOptions=[]): variant; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// initialize a variant instance to store some document-based object content

    // - object will be initialized with data supplied two by two, as Name,Value

    // pairs, e.g.

    // ! aVariant := TDocVariant.NewObject(['name','John','year',1972]);

    // which is the same as:

    // ! TDocVariant.New(aVariant);

    // ! TDocVariantData(aVariant).AddValue('name','John');

    // ! TDocVariantData(aVariant).AddValue('year',1972);

    // - by default, every internal value will be copied, so access of nested

    // properties can be slow - if you expect the data to be read-only or not

    // propagated into another place, set Options=[dvoValueCopiedByReference]

    // will increase the process speed a lot

    // - in practice, you should better use the function _Obj() which is a

    // wrapper around this class method

    class function NewObject(const NameValuePairs: array of const;

      Options: TDocVariantOptions=[]): variant;

    /// initialize a variant instance to store some document-based array content

    // - array will be initialized with data supplied as parameters, e.g.

    // ! aVariant := TDocVariant.NewArray(['one',2,3.0]);

    // which is the same as:

    // ! TDocVariant.New(aVariant);

    // ! TDocVariantData(aVariant).AddItem('one');

    // ! TDocVariantData(aVariant).AddItem(2);

    // ! TDocVariantData(aVariant).AddItem(3.0);

    // - by default, every internal value will be copied, so access of nested

    // properties can be slow - if you expect the data to be read-only or not

    // propagated into another place, set aOptions=[dvoValueCopiedByReference]

    // will increase the process speed a lot

    // - in practice, you should better use the function _Arr() which is a

    // wrapper around this class method

    class function NewArray(const Items: array of const;

      Options: TDocVariantOptions=[]): variant; overload;

    /// initialize a variant instance to store some document-based array content

    // - array will be initialized with data supplied dynamic array of variants

    class function NewArray(const Items: TVariantDynArray;

      Options: TDocVariantOptions=[]): variant; overload;

    /// initialize a variant instance to store some document-based object content

    // from a supplied (extended) JSON content

    // - in addition to the JSON RFC specification strict mode, this method will

    // handle some BSON-like extensions, e.g. unquoted field names

    // - a private copy of the incoming JSON buffer will be used, then

    // it will call the TDocVariantData.InitJSONInPlace() method

    // - to be used e.g. as:

    // ! var V: variant;

    // ! begin

    // !   V := TDocVariant.NewJSON('{"id":10,"doc":{"name":"John","birthyear":1972}}');

    // !   assert(V.id=10);

    // !   assert(V.doc.name='John');

    // !   assert(V.doc.birthYear=1972);

    // !   // and also some pseudo-properties:

    // !   assert(V._count=2);

    // !   assert(V.doc._kind=ord(dvObject));

    // - or with a JSON array:

    // !   V := TDocVariant.NewJSON('["one",2,3]');

    // !   assert(V._kind=ord(dvArray));

    // !   for i := 0 to V._count-1 do

    // !     writeln(V._(i));

    // - by default, every internal value will be copied, so access of nested

    // properties can be slow - if you expect the data to be read-only or not

    // propagated into another place, add dvoValueCopiedByReference in Options

    // will increase the process speed a lot

    // - in practice, you should better use the function _Json()/_JsonFast()

    // which are handy wrappers around this class method

    class function NewJSON(const JSON: RawUTF8;

      Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant;

      {$ifdef HASINLINE}inline;{$endif}

    /// initialize a variant instance to store some document-based object content

    // from a supplied existing TDocVariant instance

    // - 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);



    // this implementation will write the content as JSON object or array

    procedure ToJSON(W: TTextWriter; const Value: variant; Escape: TTextWriterKind); override;

    /// will check if the value is an array, and return the number of items

    // - if the document is an array, will return the items count (0 meaning

    // void array)

    // - this overridden method will implement it for dvArray instance kind

    function IterateCount(const V: TVarData): integer; override;

    /// allow to loop over an array value

    // - Index should be in 0..IterateCount-1 range

    // - this default implementation will do handle dvArray instance kind

    procedure Iterate(var Dest: TVarData; const V: TVarData; Index: integer); override;

    /// low-level callback to access internal pseudo-methods

    // - mainly the _(Index: integer): variant method to retrieve an item

    // if the document is an array

    function DoFunction(var Dest: TVarData; const V: TVarData;

      const Name: string; const Arguments: TVarDataArray): Boolean; override;

    /// low-level callback to clear the content

    procedure Clear(var V: TVarData); override;

    /// low-level callback to copy two variant content

    // - such copy will by default be done by-value, for safety

    // - if you are sure you will use the variants as read-only, you can set

    // the dvoValueCopiedByReference Option to use faster by-reference copy

    procedure Copy(var Dest: TVarData; const Source: TVarData;

      const Indirect: Boolean); override;

    /// copy two variant content by value

    // - overridden method since instance may use a by-reference copy pattern

    procedure CopyByValue(var Dest: TVarData; const Source: TVarData); override;

    /// handle type conversion

    // - only types processed by now are string/OleStr/UnicodeString/date

    procedure Cast(var Dest: TVarData; const Source: TVarData); override;

    /// handle type conversion

    // - only types processed by now are string/OleStr/UnicodeString/date

    procedure CastTo(var Dest: TVarData; const Source: TVarData;

      const AVarType: TVarType); override;

    /// compare two variant values

    // - it uses case-sensitive text comparison of the JSON representation

    // of each variant (including TDocVariant instances)

    procedure Compare(const Left, Right: TVarData;

      var Relationship: TVarCompareResult); override;

  end;



  /// define the TDocVariant storage layout

  // - if it has one or more named properties, it is a dvObject

  // - if it has no name property, it is a dvArray

  TDocVariantKind = (dvUndefined, dvObject, dvArray);



  /// method used by TDocVariantData.ReduceAsArray to filter each object

  // - should return TRUE if the item match the expectations

  TOnReducePerItem = function(Item: PDocVariantData): boolean of object;



  /// method used by TDocVariantData.ReduceAsArray to filter each object

  // - should return TRUE if the item match the expectations

  TOnReducePerValue = function(const Value: variant): boolean of object;



  {$A-} { packet object not allowed since Delphi 2009 :( }

  /// memory structure used for TDocVariant storage of any JSON/BSON

  // document-based content as variant

  // - i.e. name/value pairs for objects, or an array of values (including

  // nested documents)

  // - you can use _Obj()/_ObjFast() _Arr()/_ArrFast() _Json()/_JsonFast() or

  // _JsonFmt()/_JsonFastFmt() functions to create instances of such variants

  // - you can transtype such an allocated variant into TDocVariantData

  // to access directly its internals (like Count or Values[]/Names[]):

  // ! aVariantObject := TDocVariant.NewObject(['name','John','year',1972]);

  // ! aVariantObject := _ObjFast(['name','John','year',1972]);

  // ! with TDocVariantData(aVariantObject) do

  // !   for i := 0 to Count-1 do

  // !     writeln(Names[i],'=',Values[i]); // for an object

  // ! aVariantArray := TDocVariant.NewArray(['one',2,3.0]);

  // ! aVariantArray := _JsonFast('["one",2,3.0]');

  // ! with TDocVariantData(aVariantArray) do

  // !   for i := 0 to Count-1 do

  // !     writeln(Values[i]); // for an array

  // here, using "with TDocVariantData(...) do" syntax can be very convenient

  // - since variants may be stored by reference (i.e. as varByRef), it may

  // be a good idea to use DocVariantData(aVariant)^ or _Safe(aVariant)^ instead

  // of TDocVariantData(aVariant), if you are not sure how aVariant was allocated

  // (may be not _Obj/_Json, but retrieved as varByRef e.g. from late binding)

  {$ifdef UNICODE}

  TDocVariantData = record

  private

  {$else}

  TDocVariantData = object

  protected

  {$endif}

    VType: TVarType;

    VOptions: TDocVariantOptions;

    VKind: TDocVariantKind;

    (* 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);

    procedure SetCapacity(aValue: integer);

    function GetCapacity: integer;

      {$ifdef HASINLINE}inline;{$endif}

    // implement U[] I[] B[] D[] O[] O_[] A[] A_[] _[] properties

    function GetOrAddValueIndex(const aName: RawUTF8): integer;

    function GetVarDataByName(const aName: RawUTF8): PVariant;

    function GetRawUTF8ByName(const aName: RawUTF8): RawUTF8;

    procedure SetRawUTF8ByName(const aName, aValue: RawUTF8);

    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;

    procedure ExchgValues(v1,v2: integer);

  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

    // - if you call Init*() methods in a row, ensure you call Clear in-between

    function InitJSONFromFile(const JsonFile: 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_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 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 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

    procedure Reset;

    /// force a number of items

    // - could be used to fast add items to the internal Values[]/Names[] arrays

    // - just set VCount, do not resize the arrays: caller should ensure that

    // Capacity is big enough

    procedure SetCount(aCount: integer);

    /// low-level method called internally

    // - 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

    function InternalAdd(const aName: RawUTF8): integer;



    /// save a document as UTF-8 encoded JSON

    // - will write either a JSON object or array, depending of the internal

    // layout of this instance (i.e. Kind property value)

    // - will write  'null'  if Kind is dvUndefined

    // - implemented as just a wrapper around VariantSaveJSON()

    function ToJSON(const Prefix: RawUTF8=''; const Suffix: RawUTF8='';

      Format: TTextWriterJSONFormat=jsonCompact): RawUTF8;

    /// save an array of objects as UTF-8 encoded non expanded layout JSON

    // - returned content would be a JSON object in mORMot's TSQLTable non

    // expanded format, with reduced JSON size, i.e.

    // $ {"fieldCount":3,"values":["ID","FirstName","LastName",...']}

    // - will write '' if Kind is dvUndefined or dvObject

    // - will raise an exception if the array document is not an array of

    // objects with identical field names 

    function ToNonExpandedJSON: RawUTF8;

    /// save a document as an array of UTF-8 encoded JSON

    // - will expect the document to be a dvArray - otherwise, will raise a

    // EDocVariant exception

    // - will use VariantToUTF8() to populate the result array: as a consequence,

    // any nested custom variant types (e.g. TDocVariant) will be stored as JSON

    procedure ToRawUTF8DynArray(out Result: TRawUTF8DynArray); overload;

    /// save a document as an array of UTF-8 encoded JSON

    // - will expect the document to be a dvArray - otherwise, will raise a

    // EDocVariant exception

    // - will use VariantToUTF8() to populate the result array: as a consequence,

    // any nested custom variant types (e.g. TDocVariant) will be stored as JSON

    function ToRawUTF8DynArray: TRawUTF8DynArray; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// save a document as an CSV of UTF-8 encoded JSON

    // - will expect the document to be a dvArray - otherwise, will raise a

    // EDocVariant exception

    // - will use VariantToUTF8() to populate the result array: as a consequence,

    // any nested custom variant types (e.g. TDocVariant) will be stored as JSON

    function ToCSV(const Separator: RawUTF8=','): RawUTF8;

    /// save a document as UTF-8 encoded Name=Value pairs

    // - will follow by default the .INI format, but you can specify your

    // own expected layout

    procedure ToTextPairsVar(out result: RawUTF8; const NameValueSep: RawUTF8='=';

      const ItemSep: RawUTF8=#13#10; Escape: TTextWriterKind=twJSONEscape);

    /// save a document as UTF-8 encoded Name=Value pairs

    // - will follow by default the .INI format, but you can specify your

    // own expected layout

    function ToTextPairs(const NameValueSep: RawUTF8='=';

      const ItemSep: RawUTF8=#13#10; Escape: TTextWriterKind=twJSONEscape): RawUTF8;

      {$ifdef HASINLINE}inline;{$endif}

    /// save an array document as an array of TVarRec, i.e. an array of const

    // - will expect the document to be a dvArray - otherwise, will raise a

    // EDocVariant exception

    // - would allow to write code as such:

    // !  Doc.InitArray(['one',2,3]);

    // !  Doc.ToArrayOfConst(vr);

    // !  s := FormatUTF8('[%,%,%]',vr,[],true);

    // !  // here s='[one,2,3]') since % would be replaced by Args[] parameters

    // !  s := FormatUTF8('[?,?,?]',[],vr,true);

    // !  // here s='["one",2,3]') since ? would be escaped by Params[] parameters

    procedure ToArrayOfConst(out Result: TTVarRecDynArray); overload;

    /// save an array document as an array of TVarRec, i.e. an array of const

    // - will expect the document to be a dvArray - otherwise, will raise a

    // EDocVariant exception

    // - would allow to write code as such:

    // !  Doc.InitArray(['one',2,3]);

    // !  s := FormatUTF8('[%,%,%]',Doc.ToArrayOfConst,[],true);

    // !  // here s='[one,2,3]') since % would be replaced by Args[] parameters

    // !  s := FormatUTF8('[?,?,?]',[],Doc.ToArrayOfConst,true);

    // !  // here s='["one",2,3]') since ? would be escaped by Params[] parameters

    function ToArrayOfConst: TTVarRecDynArray; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// save an object document as an URI-encoded list of parameters

    // - object field names should be plain ASCII-7 RFC compatible identifiers

    // (0..9a..zA..Z_.~), otherwise their values are skipped

    function ToUrlEncode(const UriRoot: RawUTF8): RawUTF8;



    /// find an item index in this document from its name

    // - search will follow dvoNameCaseSensitive option of this document

    // - returns -1 if not found

    function GetValueIndex(const aName: RawUTF8): integer; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// find an item index in this document from its name

    // - returns -1 if not found

    function GetValueIndex(aName: PUTF8Char; aNameLen: integer; 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;

    /// returns a TDocVariant object containing all properties matching the

    // first characters of the supplied property name

    // - returns null if the document is not a dvObject

    // - will use IdemPChar(), so search would be case-insensitive 

    function GetValuesByStartName(const aStartName: RawUTF8;

      TrimLeftStartName: boolean=false): variant;

    /// returns a JSON object containing all properties matching the

    // first characters of the supplied property name

    // - returns null if the document is not a dvObject

    // - will use IdemPChar(), so search would be case-insensitive

    function GetJsonByStartName(const aStartName: RawUTF8): RawUTF8;

    /// find an item in this document, and returns its value as TVarData

    // - return false if aName is not found, or if the instance is not a TDocVariant

    // - return true if the name has been found, and aValue stores the value

    // - will use simple loop lookup to identify the name, unless aSortedCompare

    // is set, and would let use a faster binary search after a SortByName()

    function GetVarData(const aName: RawUTF8; var aValue: TVarData;

      aSortedCompare: TUTF8Compare=nil): boolean; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// find an item in this document, and returns its value as TVarData pointer

    // - return nil if aName is not found, or if the instance is not a TDocVariant

    // - return a pointer to the value if the name has been found

    // - after a SortByName(aSortedCompare), would use faster binary search

    function GetVarData(const aName: RawUTF8;

      aSortedCompare: TUTF8Compare=nil): PVarData; overload;

    /// find an item in this document, and returns its value as boolean

    // - return false if aName is not found, or if the instance is not a TDocVariant

    // - return true if the name has been found, and aValue stores the value

    // - after a SortByName(aSortedCompare), would use faster binary search

    // - consider using B[] property if you want simple read/write typed access

    function GetAsBoolean(const aName: RawUTF8; out aValue: boolean;

      aSortedCompare: TUTF8Compare=nil): Boolean;

    /// find an item in this document, and returns its value as integer

    // - return false if aName is not found, or if the instance is not a TDocVariant

    // - return true if the name has been found, and aValue stores the value

    // - after a SortByName(aSortedCompare), would use faster binary search

    // - consider using I[] property if you want simple read/write typed access

    function GetAsInteger(const aName: RawUTF8; out aValue: integer;

      aSortedCompare: TUTF8Compare=nil): Boolean;

    /// find an item in this document, and returns its value as integer

    // - return false if aName is not found, or if the instance is not a TDocVariant

    // - return true if the name has been found, and aValue stores the value

    // - after a SortByName(aSortedCompare), would use faster binary search

    // - consider using I[] property if you want simple read/write typed access

    function GetAsInt64(const aName: RawUTF8; out aValue: Int64;

      aSortedCompare: TUTF8Compare=nil): Boolean;

    /// find an item in this document, and returns its value as floating point

    // - return false if aName is not found, or if the instance is not a TDocVariant

    // - return true if the name has been found, and aValue stores the value

    // - after a SortByName(aSortedCompare), would use faster binary search

    // - consider using D[] property if you want simple read/write typed access

    function GetAsDouble(const aName: RawUTF8; out aValue: double;

      aSortedCompare: TUTF8Compare=nil): Boolean;

    /// find an item in this document, and returns its value as RawUTF8

    // - return false if aName is not found, or if the instance is not a TDocVariant

    // - return true if the name has been found, and aValue stores the value

    // - after a SortByName(aSortedCompare), would use faster binary search

    // - consider using U[] property if you want simple read/write typed access

    function GetAsRawUTF8(const aName: RawUTF8; out aValue: RawUTF8;

      aSortedCompare: TUTF8Compare=nil): Boolean;

    /// find an item in this document, and returns its value as a TDocVariantData

    // - return false if aName is not found, or if the instance is not a TDocVariant

    // - return true if the name has been found and points to a TDocVariant:

    // then aValue stores a pointer to the value

    // - after a SortByName(aSortedCompare), would use faster binary search

    function GetAsDocVariant(const aName: RawUTF8; out aValue: PDocVariantData;

      aSortedCompare: TUTF8Compare=nil): boolean; overload;

    /// find an item in this document, and returns its value as a TDocVariantData

    // - returns a void TDocVariant if aName is not a document

    // - after a SortByName(aSortedCompare), would use faster binary search

    // - consider using O[] or A[] properties if you want simple read-only

    // access, or O_[] or A_[] properties if you want the ability to add

    // a missing object or array in the document

    function GetAsDocVariantSafe(const aName: RawUTF8;

      aSortedCompare: TUTF8Compare=nil): PDocVariantData;

    /// find an item in this document, and returns pointer to its value

    // - return false if aName is not found

    // - return true if the name has been found: then aValue stores a pointer

    // to the value

    // - after a SortByName(aSortedCompare), would use faster binary search

    function GetAsPVariant(const aName: RawUTF8; out aValue: PVariant;

      aSortedCompare: TUTF8Compare=nil): boolean;

    /// retrieve a value, given its path

    // - path is defined as a dotted name-space, e.g. 'doc.glossary.title'

    // - it will return Unassigned if the path does match the supplied aPath

    function GetValueByPath(const aPath: RawUTF8): variant; overload;

    /// retrieve a value, given its path

    // - path is defined as a dotted name-space, e.g. 'doc.glossary.title'

    // - it will return FALSE if the path does not match the supplied aPath

    // - returns TRUE and set the found value in aValue

    function GetValueByPath(const aPath: RawUTF8; out aValue: variant): boolean; overload;

    /// retrieve a value, given its path

    // - path is defined as a list of names, e.g. ['doc','glossary','title']

    // - it will return Unassigned if the path does not match the data

    // - this method will only handle nested TDocVariant values: use the

    // slightly slower GetValueByPath() overloaded method, if any nested object

    // may be of another type (e.g. a TBSONVariant)

    function GetValueByPath(const aDocVariantPath: array of RawUTF8): variant; overload;

    /// retrieve a reference to a value, given its path

    // - path is defined as a dotted name-space, e.g. 'doc.glossary.title'

    // - if the supplied aPath does not match any object, it will return nil

    // unless addIfNotExisting=true and it would add the new object

    // - if aPath is found (or added), it will return a pointer to the

    // corresponding value  

    function GetPVariantByPath(const aPath: RawUTF8; addIfNotExisting: boolean=false): PVariant;

    /// retrieve an dvObject, from a property name in the dvArray document

    // - returns false if no object in the dvArray contains the supplied

    // "aPropName":"aPropValue" property

    // - returns true, and copy the corresponding VValue[] item into Dest

    // if a match was found

    // - create a copy of the variant by default, unless DestByRef is TRUE

    function GetItemByProp(const aPropName,aPropValue: RawUTF8;

      aCaseSensitive: boolean; var Dest: variant; DestByRef: boolean=false): boolean;

    /// retrieve an dvObject, from a property name in the dvArray document

    // - returns false if no object in the dvArray contains the supplied

    // "aPropName":"aPropValue" property

    // - returns true, and create a reference to the VValue[] item into Dest

    // if a match was found

    function GetDocVariantByProp(const aPropName,aPropValue: RawUTF8;

      aCaseSensitive: boolean; out Dest: PDocVariantData): boolean;

    /// find an item in this document, and returns its value

    // - raise an EDocVariant if not found and dvoReturnNullForUnknownProperty

    // is not set in Options (in this case, it will return Null)

    // - create a copy of the variant by default, unless DestByRef is TRUE

    procedure RetrieveValueOrRaiseException(aName: PUTF8Char; aNameLen: integer;

      aCaseSensitive: boolean; var Dest: variant; DestByRef: boolean); overload;

    /// retrieve an item in this document from its index, and returns its value

    // - raise an EDocVariant if the supplied Index is not in the 0..Count-1

    // range and dvoReturnNullForOutOfRangeIndex 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 dvoReturnNullForOutOfRangeIndex is set in Options

    procedure RetrieveNameOrRaiseException(Index: integer; var Dest: RawUTF8);

    /// set an item in this document from its index

    // - raise an EDocVariant if the supplied Index is not in 0..Count-1 range

    procedure SetValueOrRaiseException(Index: integer; const NewValue: variant);



    /// add a value in this document

    // - if aName is set, if dvoCheckForDuplicatedNames option is set, any

    // existing duplicated aName will raise an EDocVariant; if instance's

    // kind is dvArray and aName is defined, it will raise an EDocVariant

    // - aName may be '' e.g. if you want to store an array: in this case,

    // dvoCheckForDuplicatedNames option should not be set; if instance's Kind

    // is dvObject, it will raise an EDocVariant exception

    // - you can therefore write e.g.:

    // ! TDocVariant.New(aVariant);

    // ! Assert(TDocVariantData(aVariant).Kind=dvUndefined);

    // ! TDocVariantData(aVariant).AddValue('name','John');

    // ! Assert(TDocVariantData(aVariant).Kind=dvObject);

    // - returns the index of the corresponding newly added value

    function AddValue(const aName: RawUTF8; const aValue: variant): integer; overload;

    /// add a value in this document

    // - overloaded function accepting a UTF-8 encoded buffer for the name

    function AddValue(aName: PUTF8Char; aNameLen: integer; const aValue: variant): integer; overload;

    /// add a value in this document, or update an existing entry

    // - if instance's Kind is dvArray, it will raise an EDocVariant exception

    // - any existing Name would be updated with the new Value, unless

    // OnlyAddMissing is set to TRUE, in which case existing values would remain

    // - returns the index of the corresponding value, which may be just added

    function AddOrUpdateValue(const aName: RawUTF8; const aValue: variant;

      wasAdded: PBoolean=nil; OnlyAddMissing: boolean=false): integer;

    /// add a value in this document

    // - this function expects a UTF-8 text for the value, which would be

    // converted to a variant number, if possible

    // - if Update=TRUE, will set the property, even if it is existing

    function AddValueFromText(const aName,aValue: RawUTF8; Update: boolean=false): integer;

    /// add some properties to a TDocVariantData dvObject

    // - data is supplied two by two, as Name,Value pairs

    // - caller should ensure that VKind=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 VKind=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 VKind=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);

    /// 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 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 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,

    // and the corresponding item will be deleted, on match

    // - returns FALSE if no match is found, TRUE if as deleted

    function DeleteByProp(const aPropName,aPropValue: RawUTF8;

      aCaseSensitive: boolean): boolean;

    /// delete one or several value/item in this document, from its value

    // - return TRUE on success, FALSE if the supplied value does not exist

    // - if the value exists several times, all occurences would be removed

    function DeleteByValue(const aValue: Variant; CaseInsensitive: boolean=false): boolean;

    /// 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

    // - {aPropName:aPropValue} will be searched within the stored array,

    // and the corresponding item index will be returned, on match

    // - returns -1 if no match is found

    function SearchItemByProp(const aPropName,aPropValue: RawUTF8;

      aCaseSensitive: boolean): integer;

    /// 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 binary search

    procedure SortByName(Compare: TUTF8Compare=nil);

    /// sort the document object values by value

    // - do nothing if the document is not a dvObject

    procedure SortByValue(Compare: TVariantCompare);

    /// 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;

    /// 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

    property Options: TDocVariantOptions read VOptions write VOptions;

    /// returns the instance 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

    property Kind: TDocVariantKind read VKind;

    /// 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

    // dvoReturnNullForOutOfRangeIndex 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, you can use:

    // !  Doc.GetValueOrRaiseException('arr').Add(4); // won't work

    // - 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 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 dvoReturnNullForOutOfRangeIndex 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 :( }







/// 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 VKind=dvUndefined and VCount=0, so _Safe() would return

  // a valid, but void document

  // - its VType is varNull, so would be viewed as a null variant

  DocVariantDataFake: TDocVariantData = (VType:1);



/// direct access to a TDocVariantData from a given variant instance

// - return a pointer to the TDocVariantData corresponding to the variant

// instance, which may be of kind varByRef (e.g. when retrieved by late binding)

// - will return a read-only fake TDocVariantData with Kind=dvUndefined if the

// supplied variant is not a TDocVariant instance, so could be safely used

// in a with block (use "with" moderation, of course):

// ! with _Safe(aDocVariant)^ do

// !   for ndx := 0 to Count-1 do // here Count=0 for the "fake" result

// !     writeln(Names[ndx]);

function _Safe(const DocVariant: variant): PDocVariantData; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// direct access to a TDocVariantData from a given variant instance

// - return a pointer to the TDocVariantData corresponding to the variant

// instance, which may be of kind varByRef (e.g. when retrieved by late binding)

// - will check the supplied document kind, i.e. either dvObject or dvArray and

// raise a EDocVariant exception if it does not match

function _Safe(const DocVariant: variant; ExpectedKind: TDocVariantKind): PDocVariantData; overload;



/// initialize a variant instance to store some document-based object content

// - object will be initialized with data supplied two by two, as Name,Value

// pairs, e.g.

// ! aVariant := _Obj(['name','John','year',1972]);

// or even with nested objects:

// ! aVariant := _Obj(['name','John','doc',_Obj(['one',1,'two',2.0])]);

// - this global function is an alias to TDocVariant.NewObject()

// - by default, every internal value will be copied, so access of nested

// properties can be slow - if you expect the data to be read-only or not

// propagated into another place, set Options=[dvoValueCopiedByReference]

// or using _ObjFast() will increase the process speed a lot

function _Obj(const NameValuePairs: array of const;

  Options: TDocVariantOptions=[]): variant;



/// add some property values to a document-based object content

// - if Obj is a TDocVariant object, will add the Name/Value pairs

// - if Obj is not a TDocVariant, will create a new fast document,

// initialized with supplied the Name/Value pairs

// - this function will also ensure that ensure Obj is not stored by reference,

// but as a true TDocVariantData

procedure _ObjAddProps(const NameValuePairs: array of const; var Obj: variant); overload;



/// add the property values of a document to a document-based object content

// - if Document is not a TDocVariant object, will do nothing

// - if Obj is a TDocVariant object, will add Document fields to its content

// - if Obj is not a TDocVariant object, Document will be copied to Obj

procedure _ObjAddProps(const Document: variant; var Obj: variant); overload;



/// initialize a variant instance to store some document-based array content

// - array will be initialized with data supplied as parameters, e.g.

// ! aVariant := _Arr(['one',2,3.0]);

// - this global function is an alias to TDocVariant.NewArray()

// - by default, every internal value will be copied, so access of nested

// properties can be slow - if you expect the data to be read-only or not

// propagated into another place, set Options=[dvoValueCopiedByReference]

// or using _ArrFast() will increase the process speed a lot

function _Arr(const Items: array of const;

  Options: TDocVariantOptions=[]): variant;



/// initialize a variant instance to store some document-based content

// from a supplied (extended) JSON content

// - this global function is an alias to TDocVariant.NewJSON(), and

// will return an Unassigned variant if JSON content was not correctly converted

// - object or array will be initialized from the supplied JSON content, e.g.

// ! aVariant := _Json('{"id":10,"doc":{"name":"John","birthyear":1972}}');

// ! // now you can access to the properties via late binding

// ! assert(aVariant.id=10);

// ! assert(aVariant.doc.name='John');

// ! assert(aVariant.doc.birthYear=1972);

// ! // and also some pseudo-properties:

// ! assert(aVariant._count=2);

// ! assert(aVariant.doc._kind=ord(dvObject));

// ! // or with a JSON array:

// ! aVariant := _Json('["one",2,3]');

// ! assert(aVariant._kind=ord(dvArray));

// ! for i := 0 to aVariant._count-1 do

// !   writeln(aVariant._(i));

// - in addition to the JSON RFC specification strict mode, this method will

// handle some BSON-like extensions, e.g. unquoted field names:

// ! aVariant := _Json('{id:10,doc:{name:"John",birthyear:1972}}');

// - if the SynMongoDB unit is used in the application, the MongoDB Shell

// syntax will also be recognized to create TBSONVariant, like

// ! new Date()   ObjectId()   MinKey   MaxKey  /<jRegex>/<jOptions>

// see @http://docs.mongodb.org/manual/reference/mongodb-extended-json

// - by default, every internal value will be copied, so access of nested

// properties can be slow - if you expect the data to be read-only or not

// propagated into another place, add dvoValueCopiedByReference in Options

// will increase the process speed a lot, or use _JsonFast()

function _Json(const JSON: RawUTF8;

  Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// initialize a variant instance to store some document-based content

// from a supplied (extended) JSON content, with parameters formating

// - wrapper around the _Json(FormatUTF8(...,JSONFormat=true)) function,

// i.e. every Args[] will be inserted for each % and Params[] for each ?,

// with proper JSON escaping of string values, and writing nested _Obj() /

// _Arr() instances as expected JSON objects / arrays

// - typical use (in the context of SynMongoDB unit) could be:

// ! aVariant := _JSONFmt('{%:{$in:[?,?]}}',['type'],['food','snack']);

// ! aVariant := _JSONFmt('{type:{$in:?}}',[],[_Arr(['food','snack'])]);

// ! // which are the same as:

// ! aVariant := _JSONFmt('{type:{$in:["food","snack"]}}');

// ! // in this context:

// ! u := VariantSaveJSON(aVariant);

// ! assert(u='{"type":{"$in":["food","snack"]}}');

// ! u := VariantSaveMongoJSON(aVariant,modMongoShell);

// ! assert(u='{type:{$in:["food","snack"]}}');

// - by default, every internal value will be copied, so access of nested

// properties can be slow - if you expect the data to be read-only or not

// propagated into another place, add dvoValueCopiedByReference in Options

// will increase the process speed a lot, or use _JsonFast()

function _JsonFmt(const Format: RawUTF8; const Args,Params: array of const;

  Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant; overload;



/// initialize a variant instance to store some document-based content

// from a supplied (extended) JSON content, with parameters formating

// - this overload function will set directly a local variant variable,

// and would be used by inlined _JsonFmt/_JsonFastFmt functions 

procedure _JsonFmt(const Format: RawUTF8; const Args,Params: array of const;

  Options: TDocVariantOptions; out result: variant); overload;



/// initialize a variant instance to store some document-based content

// from a supplied (extended) JSON content

// - this global function is an alias to TDocVariant.NewJSON(), and

// will return TRUE if JSON content was correctly converted into a variant

// - in addition to the JSON RFC specification strict mode, this method will

// handle some BSON-like extensions, e.g. unquoted field names or ObjectID()

// - by default, every internal value will be copied, so access of nested

// properties can be slow - if you expect the data to be read-only or not

// propagated into another place, add dvoValueCopiedByReference in Options

// will increase the process speed a lot, or use _JsonFast()

function _Json(const JSON: RawUTF8; var Value: variant;

  Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): boolean; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// initialize a variant instance to store some document-based object content

// - this global function is an handy alias to:

// ! Obj(NameValuePairs,JSON_OPTIONS[true]);

// - so all created objects and arrays will be handled by reference, for best

// speed - but you should better write on the resulting variant tree with caution

function _ObjFast(const NameValuePairs: array of const): variant; overload;



/// initialize a variant instance to store any object as a TDocVariant

// - is a wrapper around _JsonFast(ObjectToJson(aObject,aOptions))

function _ObjFast(aObject: TObject;

   aOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]): variant; overload;



/// initialize a variant instance to store some document-based array content

// - this global function is an handy alias to:

// ! _Array(Items,JSON_OPTIONS[true]);

// - so all created objects and arrays will be handled by reference, for best

// speed - but you should better write on the resulting variant tree with caution

function _ArrFast(const Items: array of const): variant; overload;



/// initialize a variant instance to store some document-based content

// from a supplied (extended) JSON content

// - this global function is an handy alias to:

// ! _Json(JSON,JSON_OPTIONS[true]);

// so it will return an Unassigned variant if JSON content was not correct

// - so all created objects and arrays will be handled by reference, for best

// speed - but you should better write on the resulting variant tree with caution

// - in addition to the JSON RFC specification strict mode, this method will

// handle some BSON-like extensions, e.g. unquoted field names or ObjectID()

function _JsonFast(const JSON: RawUTF8): variant;

  {$ifdef HASINLINE}inline;{$endif}



/// initialize a variant instance to store some document-based content

// from a supplied (extended) JSON content, with parameters formating

// - this global function is an handy alias e.g. to:

// ! aVariant := _JSONFmt('{%:{$in:[?,?]}}',['type'],['food','snack'],JSON_OPTIONS[true]);

// - so all created objects and arrays will be handled by reference, for best

// speed - but you should better write on the resulting variant tree with caution

// - in addition to the JSON RFC specification strict mode, this method will

// handle some BSON-like extensions, e.g. unquoted field names or ObjectID():

function _JsonFastFmt(const Format: RawUTF8; const Args,Params: array of const): variant;



/// ensure a document-based variant instance will have only per-value nested

// objects or array documents

// - is just a wrapper around:

// ! TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS[false])

// - you can use this function to ensure that all internal properties of this

// variant will be copied per-value whatever options the nested objects or

// arrays were created with

// - for huge document with a big depth of nested objects or arrays, a full

// per-value copy may be time and resource consuming, but will be also safe

// - will raise an EDocVariant if the supplied variant is not a TDocVariant or

// a varByRef pointing to a TDocVariant

procedure _Unique(var DocVariant: variant);



/// ensure a document-based variant instance will have only per-value nested

// objects or array documents

// - is just a wrapper around:

// ! TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS[true])

// - you can use this function to ensure that all internal properties of this

// variant will be copied per-reference whatever options the nested objects or

// arrays were created with

// - for huge document with a big depth of nested objects or arrays, it will

// first create a whole copy of the document nodes, but further assignments

// of the resulting value will be per-reference, so will be almost instant

// - will raise an EDocVariant if the supplied variant is not a TDocVariant or

// a varByRef pointing to a TDocVariant

procedure _UniqueFast(var DocVariant: variant);



/// return a full nested copy of a document-based variant instance

// - is just a wrapper around:

// ! TDocVariant.NewUnique(DocVariant,JSON_OPTIONS[false])

// - you can use this function to ensure that all internal properties of this

// variant will be copied per-value whatever options the nested objects or

// arrays were created with

// - 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

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

// - 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

function _CopyFast(const DocVariant: variant): variant;

  {$ifdef HASINLINE}inline;{$endif}





{$endif NOVARIANTS}



{ ************ some console functions ************************************** }



type

  /// available console colors (under Windows at least)

  TConsoleColor = (

    ccBlack, ccBlue, ccGreen, ccCyan, ccRed, ccMagenta, ccBrown, ccLightGray,

    ccDarkGray, ccLightBlue, ccLightGreen, ccLightCyan, ccLightRed, ccLightMagenta,

    ccYellow, ccWhite);



/// change the Windows console text writing color

// - call this procedure to initialize internal console process, if you manually

// intialized the Windows console, e.g. via the following code:

// ! AllocConsole;

// ! TextColor(ccLightGray);

procedure TextColor(Color: TConsoleColor);



/// change the Windows console text background color

procedure TextBackground(Color: TConsoleColor);



/// will wait for the ENTER key to be pressed, processing the internal

// Windows Message loop and any Synchronize() pending notification

// - to be used e.g. for proper work of console applications with interface-based

// service implemented as optExecInMainThread

procedure ConsoleWaitForEnterKey;



{$ifdef MSWINDOWS}

/// low-level access to the keyboard state of a given key

function ConsoleKeyPressed(ExpectedKey: Word): Boolean;

{$endif}



/// direct conversion of a UTF-8 encoded string into a console OEM-encoded String

// - under Windows, will use the CP_OEMCP encoding

// - under Linux, will expect the console is defined with UTF-8 encoding

function Utf8ToConsole(const S: RawUTF8): 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);



var

  /// low-level handle used for console writing

  // - may be overriden when console is redirected

  StdOut: THandle;





{ ******************* 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: 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 = {$ifndef UNICODE}object{$else}record{$endif}

  private

    iStart,iStop,iResume,iLast: Int64;

    iFreq: Int64;

    /// contains the time elapsed in micro seconds between Start and Stop

    iTime: TSynMonitorTotalMicroSec;

    /// contains the time elapsed in micro seconds between Resume and Pause

    iLastTime: TSynMonitorOneMicroSec;

    fPauseCount: TSynMonitorCount;

  public

    /// initialize the timer

    // - not necessary if created on the heap (e.g. as class member)

    // - will set all fields to 0

    procedure Init;

    /// initialize and start the high resolution timer

    procedure Start;

    /// stop the timer, setting the Time elapsed since last Start

    procedure ComputeTime;

    /// stop the timer, returning the time elapsed as text with time resolution

    // (us,ms,s)

    // - is just a wrapper around ComputeTime + GetTime

    function Stop: RawUTF8;

    /// stop the timer, ready to continue its time measurement via Resume

    procedure Pause;

    /// resume a paused timer

    // - if the previous method called was Pause, it will ignore all the

    // time elapsed since then

    // - if the previous method called was Start, it will start as if it was

    // in pause mode

    procedure Resume;

    /// resume a paused timer until the method ends

    // - will internaly create a TInterfaceObject class to let the compiler

    // generate a try..finally block as expected to call Pause at method ending

    // - is therefore very convenient to have consistent Resume/Pause calls

    // - for proper use, expect TPrecisionTimer to be initialized to 0 before

    // execution (e.g. define it as a protected member of a class)

    // - typical use is to declare a fTimeElapsed: TPrecisionTimer protected

    // member, then call fTimeElapsed.ProfileCurrentMethod at the beginning of

    // all process expecting some timing, then log/save fTimeElapsed.Stop content

    function ProfileCurrentMethod: IUnknown;

    /// low-level method to force values settings to allow thread safe timing

    // - by default, this timer is not thread safe: you can use this method to

    // set the timing values from manually computed performance counters

    // - the caller should also use a mutex to prevent from race conditions:

    // see e.g. TSynMonitor.FromExternalQueryPerformanceCounters implementation

    // - returns the time elapsed, in micro seconds (i.e. LastTime value)

    // - warning: Start, Stop, Pause and Resume methods are then disallowed

    function FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord;

    /// low-level method to force values settings to allow thread safe timing

    // - by default, this timer is not thread safe: you can use this method to

    // set the timing values from manually computed performance counters

    // - the caller should also use a mutex to prevent from race conditions:

    // see e.g. TSynMonitor.FromExternalMicroSeconds implementation

    // - warning: Start, Stop, Pause and Resume methods are then disallowed

    procedure FromExternalMicroSeconds(const MicroSeconds: QWord);

      {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell

    /// compute the per second count

    function PerSec(const Count: QWord): QWord;

    /// compute the time elapsed by count, with appened time resolution (us,ms,s)

    function ByCount(Count: QWord): RawUTF8;

    /// textual representation of time after counter stopped

    // - with appened time resolution (us,ms,s)

    // - not to be used in normal code, but e.g. for custom performance analysis

    function Time: RawUTF8;

    /// 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 iTime write iTime;

    /// textual representation of last process timing after counter stopped

    // - with appened time resolution (us,ms,s)

    // - not to be used in normal code, but e.g. for custom performance analysis

    function LastTime: RawUTF8;

    /// 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 iLastTime write iLastTime;

    /// 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: RawUTF8;

    /// stop the timer, ready to continue its time measure

    procedure Pause;

    /// resume a paused timer

    procedure Resume;

    /// compute the per second count

    function PerSec(Count: cardinal): cardinal;

    /// compute the time elapsed by count, with appened time resolution (us,ms,s)

    function ByCount(Count: cardinal): RawUTF8;

  end;



  /// reference counted high resolution timer (for accurate speed statistics)

  // - since TPrecisionTimer shall be 32 bit aligned, you can use this class

  // to initialize a local auto-freeing ILocalPrecisionTimer variable on stack

  // - to be used as such:

  // ! var Timer: ILocalPrecisionTimer;

  // !  (...)

  // !   Timer := TLocalPrecisionTimer.Create;

  // !   Timer.Start;

  // !  (...)

  TLocalPrecisionTimer = class(TInterfacedObject,ILocalPrecisionTimer)

  protected

    fTimer: TPrecisionTimer;

  public

    /// initialize the instance, and start the high resolution timer

    constructor CreateAndStart;

    /// start the high resolution timer

    procedure Start;

    /// stop the timer, returning the time elapsed, with appened time resolution (us,ms,s)

    function Stop: RawUTF8;

    /// stop the timer, ready to continue its time measure

    procedure Pause;

    /// resume a paused timer

    procedure Resume;

    /// compute the per second count

    function PerSec(Count: cardinal): cardinal;

    /// compute the time elapsed by count, with appened time resolution (us,ms,s)

    function ByCount(Count: cardinal): RawUTF8;

  end;



  {$M+}



  /// 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

  protected

    fMicroSeconds: TSynMonitorTotalMicroSec;

    function GetAsText: RawUTF8;

  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: RawUTF8 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

  protected

    fMicroSeconds: TSynMonitorOneMicroSec;

    function GetAsText: RawUTF8;

  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: RawUTF8 read GetAsText;

  end;



  /// able to serialize any cumulative size as bytes number

  // - "cumulative" time would add each process value, e.g. global IO

  TSynMonitorSize = class

  protected

    fBytes: TSynMonitorTotalBytes;

    function GetAsText: RawUTF8;

  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: RawUTF8 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

  protected

    fBytes: TSynMonitorOneBytes;

    function GetAsText: RawUTF8;

  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: RawUTF8 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

  protected

    fBytesPerSec: QWord;

    function GetAsText: RawUTF8;

  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: RawUTF8 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(TSynPersistent)

  protected

    fName: RawUTF8;

    fProcessing: boolean;

    fTaskCount: TSynMonitorCount64;

    fInternalErrors: TSynMonitorCount;

    fLastInternalError: variant;

    fTotalTime: TSynMonitorTime;

    fLastTime: TSynMonitorOneTime;

    fMinimalTime: TSynMonitorOneTime;

    fAverageTime: TSynMonitorOneTime;

    fMaximalTime: TSynMonitorOneTime;

    fPerSec: QWord;

    fTaskStatus: (taskNotStarted,taskStarted);

    fLock: TRTLCriticalSection;

    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 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}

    /// 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

    /// increase the internal size counters

    // - thread-safe method

    procedure AddSize(const Incoming, Outgoing: QWord);

  published

    /// initialize the instance nested class properties

    constructor Create; override;

    /// finalize the instance

    destructor Destroy; override;

    /// 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;



  {$M-}



  /// 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;



  /// 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; override;

    /// 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: 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: RawUTF8;

    fVolumeName: RawUTF8;

    fAvailableSize: TSynMonitorOneSize;

    fFreeSize: TSynMonitorOneSize;

    fTotalSize: TSynMonitorOneSize;

    fLastDiskInfoRetrievedTix: cardinal;

    procedure RetrieveDiskInfo; virtual;

    function GetName: RawUTF8;

    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: RawUTF8 read GetName;

    /// the volume name

    property VolumeName: RawUTF8 read fVolumeName write fVolumeName;

    /// space currently available on this disk for the current user

    // - may be less then FreeSize, if user quotas are specified

    property AvailableSize: TSynMonitorOneSize read GetAvailable;

    /// free space currently available on this disk

    property FreeSize: TSynMonitorOneSize read GetFree;

    /// total space

    property TotalSize: TSynMonitorOneSize read GetTotal;

  end;







{ ******************* 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 MSWINDOWS}

{$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

    fExpected8087, fSaved8087: word;

    function VirtualAddRef: Integer; override;

    function VirtualRelease: Integer; override;

  public

    /// internal constructor

    // - do not call this constructor directly, but rather use

    // ForLibraryCode/ForDelphiCode class methods

    // - flags are $1332 for Delphi, or $133F for library (mask all exceptions)

    constructor Create(Expected8087Flag: word); reintroduce;

    /// 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

    // - 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)

    // - you have to put this e.g. before running an external libray

    // - this method is thread-safe and re-entrant (by reference-counting)

    class function ForDelphiCode: IUnknown;

  end;



{$endif DELPHI5OROLDER}

{$endif MSWINDOWS}



  /// interface for TAutoFree to register another TObject instance

  // to an existing IAutoFree local variable

  IAutoFree = interface

    procedure Another(var objVar; obj: TObject);

  end;



  /// simple reference-counted storage for local objects

  // - be aware that it won't implement a full ARC memory model, but may be

  // just used to avoid writing some try ... finally blocks on local variables

  // - use with caution, only on well defined local scope

  TAutoFree = class(TInterfacedObject,IAutoFree)

  protected

    fObject: TObject;

    fObjectList: array of TObject;

  public

    /// initialize the TAutoFree class for one local variable

    // - do not call this constructor, but class function One() instead

    constructor Create(var localVariable; obj: TObject); reintroduce; overload;

    /// initialize the TAutoFree class for several local variables

    // - do not call this constructor, but class function Several() instead

    constructor Create(const varObjPairs: array of pointer); reintroduce; overload;

    /// protect one local TObject variable instance life time

    // - for instance, instead of writing:

    // !var myVar: TMyClass;

    // !begin

    // !  myVar := TMyClass.Create;

    // !  try

    // !    ... use myVar

    // !  finally

    // !    myVar.Free;

    // !  end;

    // !end;

    // - you may write:

    // !var myVar: TMyClass;

    // !begin

    // !  TAutoFree.One(myVar,TMyClass.Create);

    // !  ... use myVar

    // !end; // here myVar will be released

    // - warning: under FPC, you should assign the result of this method to a local

    // IAutoFree variable - see bug http://bugs.freepascal.org/view.php?id=26602

    class function One(var localVariable; obj: TObject): IAutoFree;

    /// protect several local TObject variable instances life time

    // - specified as localVariable/objectInstance pairs

    // - you may write:

    // !var var1,var2: TMyClass;

    // !begin

    // !  TAutoFree.Several([

    // !    @var1,TMyClass.Create,

    // !    @var2,TMyClass.Create]);

    // !  ... use var1 and var2

    // !end; // here var1 and var2 will be released

    // - warning: under FPC, you should assign the result of this method to a local

    // IAutoFree variable - see bug http://bugs.freepascal.org/view.php?id=26602

     class function Several(const varObjPairs: array of pointer): IAutoFree;

    /// protect another TObject variable to an existing IAutoFree instance life time

    // - you may write:

    // !var var1,var2: TMyClass;

    // !    auto: IAutoFree;

    // !begin

    // !  auto := TAutoFree.One(var1,TMyClass.Create);,

    // !  .... do something

    // !  auto.Another(var2,TMyClass.Create);

    // !  ... use var1 and var2

    // !end; // here var1 and var2 will be released

    procedure Another(var localVariable; obj: TObject);

    /// will finalize the associated TObject instances

    // - note that releasing the TObject instances won't be protected, so

    // any exception here may induce a memory leak: use only with "safe"

    // simple objects, e.g. mORMot's TSQLRecord

    destructor Destroy; override;

  end;



  {$ifdef DELPHI5OROLDER} // IAutoLocker -> internal error C3517 under Delphi 5 :(

  TAutoLocker = class

  {$else}

  /// 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

  TAutoLocker = class(TInterfacedObjectWithCustomCreate,IAutoLocker)

  {$endif DELPHI5OROLDER}

  protected

    fSafe: TSynLocker;

  public

    /// initialize the mutex

    constructor Create; {$ifndef DELPHI5OROLDER} override; {$endif}

    /// finalize the mutex

    destructor Destroy; override;

    /// will enter the mutex until the IUnknown reference is released

    // - 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

    // - 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

    procedure Leave; virtual;

    /// access to the locking methods of this instance

    function Safe: PSynLocker;

  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: TAutoLocker;

    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; const aSafe: TSynLocker); 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: TObjectListLocked;

    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;



{$ifndef DELPHI5OROLDER} // internal error C3517 under Delphi 5 :(

{$ifndef NOVARIANTS}

  /// ref-counted interface for thread-safe access to a TDocVariant document

  // - is implemented e.g. by TLockedDocVariant, for IoC/DI resolution

  // - fast and safe storage of any JSON-like object, as property/value pairs,

  // or a JSON-like array, as values

  ILockedDocVariant = interface

    ['{CADC2C20-3F5D-4539-9D23-275E833A86F3}']

    function GetValue(const Name: RawUTF8): Variant;

    procedure SetValue(const Name: RawUTF8; const Value: Variant);

    /// check and return a given property by name

    // - returns TRUE and fill Value with the value associated with the supplied

    // Name, using an internal lock for thread-safety

    // - returns FALSE if the Name was not found, releasing the internal lock:

    // use ExistsOrLock() if you want to add the missing value

    function Exists(const Name: RawUTF8; out Value: Variant): boolean;

    /// check and return a given property by name

    // - returns TRUE and fill Value with the value associated with the supplied

    // Name, using an internal lock for thread-safety

    // - returns FALSE and set the internal lock if Name does not exist:

    // caller should then release the lock via ReplaceAndUnlock()

    function ExistsOrLock(const Name: RawUTF8; out Value: Variant): boolean;

    /// set a value by property name, and set a local copy

    // - could be used as such, for implementing a thread-safe cache:

    // ! if not cache.ExistsOrLock('prop',local) then

    // !   cache.ReplaceAndUnlock('prop',newValue,local);

    // - call of this method should have been precedeed by ExistsOrLock()

    // returning false, i.e. be executed on a locked instance

    procedure ReplaceAndUnlock(const Name: RawUTF8; const Value: Variant; out LocalValue: Variant);

    /// add an existing property value to the given TDocVariant document object

    // - returns TRUE and add the Name/Value pair to Obj if Name is existing,

    // using an internal lock for thread-safety

    // - returns FALSE if Name is not existing in the stored document, and

    // lock the internal storage: caller should eventually release the lock

    // via AddNewPropAndUnlock()

    // - could be used as such, for implementing a thread-safe cache:

    // ! if not cache.AddExistingPropOrLock('Articles',Scope) then

    // !   cache.AddNewPropAndUnlock('Articles',GetArticlesFromDB,Scope);

    // here GetArticlesFromDB would occur inside the main lock

    function AddExistingPropOrLock(const Name: RawUTF8; var Obj: variant): boolean;

    /// add a property value to the given TDocVariant document object and

    // to the internal stored document, then release a previous lock

    // - call of this method should have been precedeed by AddExistingPropOrLock()

    // returning false, i.e. be executed on a locked instance

    procedure AddNewPropAndUnlock(const Name: RawUTF8; const Value: variant; var Obj: variant);

    /// add an existing property value to the given TDocVariant document object

    // - returns TRUE and add the Name/Value pair to Obj if Name is existing

    // - returns FALSE if Name is not existing in the stored document

    // - this method would use a lock during the Name lookup, but would always

    // release the lock, even if returning FALSE (see AddExistingPropOrLock)

    function AddExistingProp(const Name: RawUTF8; var Obj: variant): boolean;

    /// add a property value to the given TDocVariant document object

    // - this method would not expect the resource to be locked when called,

    // as with AddNewPropAndUnlock

    // - will use the internal lock for thread-safety

    // - if the Name is already existing, would update/change the existing value

    // - could be used as such, for implementing a thread-safe cache:

    // ! if not cache.AddExistingProp('Articles',Scope) then

    // !   cache.AddNewProp('Articles',GetArticlesFromDB,Scope);

    // here GetArticlesFromDB would occur outside the main lock

    procedure AddNewProp(const Name: RawUTF8; const Value: variant; var Obj: variant);

    /// append a value to the internal TDocVariant document array

    // - you should not use this method in conjunction with other document-based

    // alternatives, like Exists/AddExistingPropOrLock or AddExistingProp

    procedure AddItem(const Value: variant);

    /// makes a thread-safe copy of the internal TDocVariant document object or array

    function Copy: variant;

    /// delete all stored properties

    procedure Clear;

    /// save the stored values as UTF-8 encoded JSON Object

    function ToJSON(HumanReadable: boolean=false): RawUTF8;

    /// the document fields would be safely accessed via this property

    // - this is the main entry point of this storage

    // - would raise an EDocVariant exception if Name does not exist at reading

    // - implementation class would make a thread-safe copy of the variant value

    property Value[const Name: RawUTF8]: Variant read GetValue write SetValue; default;

  end;



  /// allows thread-safe access to a TDocVariant document

  // - this class inherits from TInterfacedObjectWithCustomCreate so you

  // could define one published property of a mORMot.pas' TInjectableObject

  // as ILockedDocVariant so that this class may be automatically injected

  TLockedDocVariant = class(TInterfacedObjectWithCustomCreate,ILockedDocVariant)

  protected

    fValue: TDocVariantData;

    fLock: TAutoLocker;

    function GetValue(const Name: RawUTF8): Variant;

    procedure SetValue(const Name: RawUTF8; const Value: Variant);

  public

    /// initialize the thread-safe document with a fast TDocVariant

    // - i.e. call Create(true) aka Create(JSON_OPTIONS[true])

    // - will be the TInterfacedObjectWithCustomCreate default constructor,

    // called e.g. during IoC/DI resolution

    constructor Create; overload; override;

    /// initialize the thread-safe document storage

    constructor Create(FastStorage: boolean); reintroduce; overload;

    /// initialize the thread-safe document storage with the corresponding options

    constructor Create(options: TDocVariantOptions); reintroduce; overload;

    /// finalize the storage

    destructor Destroy; override;

    /// check and return a given property by name

    function Exists(const Name: RawUTF8; out Value: Variant): boolean;

    /// check and return a given property by name

    // - this version 

    function ExistsOrLock(const Name: RawUTF8; out Value: Variant): boolean;

    /// set a value by property name, and set a local copy

    procedure ReplaceAndUnlock(const Name: RawUTF8; const Value: Variant; out LocalValue: Variant);

    /// add an existing property value to the given TDocVariant document object

    // - returns TRUE and add the Name/Value pair to Obj if Name is existing

    // - returns FALSE if Name is not existing in the stored document

    function AddExistingPropOrLock(const Name: RawUTF8; var Obj: variant): boolean;

    /// add a property value to the given TDocVariant document object and

    // to the internal stored document

    procedure AddNewPropAndUnlock(const Name: RawUTF8; const Value: variant; var Obj: variant);

    /// add an existing property value to the given TDocVariant document object

    // - returns TRUE and add the Name/Value pair to Obj if Name is existing

    // - returns FALSE if Name is not existing in the stored document

    // - this method would use a lock during the Name lookup, but would always

    // release the lock, even if returning FALSE (see AddExistingPropOrLock)

    function AddExistingProp(const Name: RawUTF8; var Obj: variant): boolean;

    /// add a property value to the given TDocVariant document object

    // - this method would not expect the resource to be locked when called,

    // as with AddNewPropAndUnlock

    // - will use the internal lock for thread-safety

    // - if the Name is already existing, would update/change the existing value

    procedure AddNewProp(const Name: RawUTF8; const Value: variant; var Obj: variant);

    /// append a value to the internal TDocVariant document array

    procedure AddItem(const Value: variant);

    /// makes a thread-safe copy of the internal TDocVariant document object or array

    function Copy: variant;

    /// delete all stored properties

    procedure Clear;

    /// save the stored value as UTF-8 encoded JSON Object

    // - implemented as just a wrapper around VariantSaveJSON()

    function ToJSON(HumanReadable: boolean=false): RawUTF8;

    /// the document fields would be safely accessed via this property

    // - would 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

  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); 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

    property Stats: TSynMonitor read fStats;

  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;

  public

    /// initialize the authentication scheme

    constructor Create;

    /// finalize the authentation

    destructor Destroy; override;

    /// register one credential for a given user

    // - this abstract method would 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 would 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, 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

    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;

    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

  /// 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

  {$ifndef UNICODE}

  TSynUniqueIdentifierBits = object

  {$else}

  TSynUniqueIdentifierBits = record

  {$endif}

  public

    /// the actual 64-bit storage value

    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: cardinal;

      {$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;

    {$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}

    /// 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(aDateTime: TDateTime);

  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

  // - 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

    fLastTix: cardinal;

    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(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(aUnixTime: Int64; 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;

  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;

  



/// convert a size to a human readable value

// - append TB, GB, MB, KB or B symbol

// - for TB, GB, MB and KB, add one fractional digit

function KB(bytes: Int64): RawUTF8;



/// convert a micro seconds elapsed time into a human readable value

// - append 'us', 'ms' or 's' symbol

// - for 'us' and 'ms', add two fractional digits

function MicroSecToString(Micro: QWord): RawUTF8;



/// 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: RawUTF8=','): RawUTF8;



/// return the Delphi Compiler Version

// - returns 'Delphi 2007' or 'Delphi 2010' e.g.

function GetDelphiCompilerVersion: RawUTF8;



/// returns TRUE if the supplied mutex has been initialized

// - will check if the supplied mutex is void (i.e. all filled with 0 bytes)

function IsInitializedCriticalSection(const CS: TRTLCriticalSection): Boolean;

  {$ifdef HASINLINE}inline;{$endif}



/// on need initialization of a mutex, then enter the lock

// - if the supplied mutex has been initialized, do nothing

// - if the supplied mutex is void (i.e. all filled with 0), initialize it

procedure InitializeCriticalSectionIfNeededAndEnter(var CS: TRTLCriticalSection);

  {$ifdef HASINLINE}inline;{$endif}



/// on need finalization of a mutex

// - if the supplied mutex has been initialized, delete it

// - if the supplied mutex is void (i.e. all filled with 0), do nothing

procedure DeleteCriticalSectionIfNeeded(var CS: TRTLCriticalSection);



/// compress a data content using the SynLZ algorithm

// - as expected by THttpSocket.RegisterCompress

// - will return 'synlz' as ACCEPT-ENCODING: header parameter

// - will store a hash of both compressed and uncompressed stream: if the

// data is corrupted during transmission, will instantly return ''

function CompressSynLZ(var DataRawByteString; Compress: boolean): AnsiString;



/// compress a data content using the SynLZ algorithm from one stream into another

// - returns the number of bytes written to Dest

// - you should specify a Magic number to be used to identify the block

function StreamSynLZ(Source: TCustomMemoryStream; Dest: TStream;

  Magic: cardinal): integer; overload;



/// compress a data content using the SynLZ algorithm from one stream into a file

// - returns the number of bytes written to the destination file

// - you should specify a Magic number to be used to identify the block

function StreamSynLZ(Source: TCustomMemoryStream; const DestFile: TFileName;

  Magic: cardinal): integer; overload;



/// uncompress using the SynLZ algorithm from one stream into another

// - returns a newly create memory stream containing the uncompressed data

// - returns nil if source data is invalid

// - you should specify a Magic number to be used to identify the block

// - this function will also recognize the block at the end of the source stream

// (if was appended to an existing data - e.g. a .mab at the end of a .exe)

// - on success, Source will point after all read data (so that you can e.g.

// append several data blocks to the same stream)

function StreamUnSynLZ(Source: TStream; Magic: cardinal): TMemoryStream; overload;



/// compute the real length of a given StreamSynLZ-compressed buffer

// - allows to replace an existing appended content, for instance

function StreamSynLZComputeLen(P: PAnsiChar; Len, aMagic: cardinal): integer;



/// uncompress using the SynLZ algorithm from one file into another

// - returns a newly create memory stream containing the uncompressed data

// - returns nil if source file is invalid (e.g. invalid name or invalid content)

// - you should specify a Magic number to be used to identify the block

// - this function will also recognize the block at the end of the source file

// (if was appended to an existing data - e.g. a .mab at the end of a .exe)

function StreamUnSynLZ(const Source: TFileName; Magic: cardinal): TMemoryStream; overload;



/// compress a file content using the SynLZ algorithm a file content

// - source file is split into 128 MB blocks for fast in-memory compression of

// any file size

// - you should specify a Magic number to be used to identify the compressed

// file format

function FileSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean;



/// compress a file content using the SynLZ algorithm a file content

// - you should specify a Magic number to be used to identify the compressed

// file format

function FileUnSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean;



/// returns TRUE if the supplied file name is a SynLZ compressed file,

// matching the Magic number as supplied to FileSynLZ() function

function FileIsZynLZ(const Name: TFileName; Magic: Cardinal): boolean;



/// compress a memory bufer using the SynLZ algorithm and crc32c hashing

function SynLZCompress(const Data: RawByteString; CompressionSizeTrigger: integer=100): RawByteString; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// compress a memory bufer using the SynLZ algorithm and crc32c hashing

procedure SynLZCompress(P: PAnsiChar; PLen: integer; out Result: RawByteString;

  CompressionSizeTrigger: integer=100); overload;



/// uncompress a memory bufer using the SynLZ algorithm and crc32c hashing

function SynLZDecompress(const Data: RawByteString): RawByteString; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// uncompress a memory bufer using the SynLZ algorithm and crc32c hashing

procedure SynLZDecompress(P: PAnsiChar; PLen: integer; out Result: RawByteString); overload;



/// compress a memory bufer using the SynLZ algorithm and crc32c hashing

function SynLZCompressToBytes(const Data: RawByteString;

  CompressionSizeTrigger: integer=100): TByteDynArray; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// compress a memory bufer using the SynLZ algorithm and crc32c hashing

function SynLZCompressToBytes(P: PAnsiChar; PLen: integer;

  CompressionSizeTrigger: integer=100): TByteDynArray; overload;



/// uncompress a memory bufer using the SynLZ algorithm and crc32c hashing

function SynLZDecompress(const Data: TByteDynArray): RawByteString; overload;



/// directly returns the buffer

// - returns nil if crc32 hash failed, i.e. if the supplied Data is not correct

// - returns a pointer to the raw data and fill Len 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 SynLZDecompress(const Data: RawByteString; out Len: integer;

  var tmp: RawByteString): pointer; overload;



/// directly returns a stored buffer, if SynLZCompress() just stored it

// - returns nil if crc32 hash failed, i.e. if the supplied Data is not correct

// - returns a pointer to the raw data and fill Len 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 SynLZDecompress(P: PAnsiChar; PLen: integer; out Len: integer;

  var tmp: RawByteString): pointer; overload;



/// 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; out 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;





resourcestring

  sInvalidIPAddress = '"%s" is an invalid IP v4 address';

  sInvalidEmailAddress = '"%s" is an invalid email address';

  sInvalidPattern = '"%s" does not match the expected pattern';

  sCharacter01n = 'character,character,characters';

  sInvalidTextLengthMin = 'Expect at least %d %s';

  sInvalidTextLengthMax = 'Expect up to %d %s';

  sInvalidTextChar = 'Expect at least %d %s %s,Expect up to %d %s %s,'+

    'alphabetical,digital,punctuation,lowercase,uppercase,space,'+

    'Too much spaces on the left,Too much spaces on the right';

  sValidationFailed = '"%s" rule failed';

  sValidationFieldVoid = 'An unique key field must not be void';

  sValidationFieldDuplicate = 'Value already used for this unique key field';





implementation



{$ifdef FPC}

uses

  {$ifdef Linux}

  SynFPCLinux, Unix, dynlibs, Linux,

  {$ifndef Darwin}

  SysCall,

  {$endif}

  {$endif}

  SynFPCTypInfo, TypInfo; // small wrapper unit around FPC's TypInfo.pp

{$endif}





{ ************ some fast UTF-8 / Unicode / Ansi conversion routines }



var

  // internal list of TSynAnsiConvert instances

  SynAnsiConvertList: TObjectList = nil;



// some constants used for UTF-8 conversion, including surrogates

const

  UTF16_HISURROGATE_MIN = $d800;

  UTF16_HISURROGATE_MAX = $dbff;

  UTF16_LOSURROGATE_MIN = $dc00;

  UTF16_LOSURROGATE_MAX = $dfff;

  UTF8_EXTRABYTES: array[$80..$ff] of byte = (

    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,

    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,

    1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,

    2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,4,4,4,4,5,5,0,0);

  UTF8_EXTRA: array[0..6] of record

    offset, minimum: cardinal;

  end = ( // http://floodyberry.wordpress.com/2007/04/14/utf-8-conversion-tricks

    (offset: $00000000;  minimum: $00010000),

    (offset: $00003080;  minimum: $00000080),

    (offset: $000e2080;  minimum: $00000800),

    (offset: $03c82080;  minimum: $00010000),

    (offset: $fa082080;  minimum: $00200000),

    (offset: $82082080;  minimum: $04000000),

    (offset: $00000000;  minimum: $04000000));

  UTF8_EXTRA_SURROGATE = 3;

  UTF8_FIRSTBYTE: array[2..6] of byte = ($c0,$e0,$f0,$f8,$fc);





{ TSynAnsiConvert }



const

  DefaultCharVar: AnsiChar = '?';



function TSynAnsiConvert.AnsiBufferToUnicode(Dest: PWideChar;

  Source: PAnsiChar; SourceChars: Cardinal): PWideChar;

var c: cardinal;

{$ifndef MSWINDOWS}

{$ifdef FPC}

    tmp: UnicodeString;

{$endif}

{$ifdef KYLIX3}

    ic: iconv_t;

    DestBegin: PAnsiChar;

    SourceCharsBegin: integer;

{$endif}

{$endif}

begin

  {$ifdef KYLIX3}

  SourceCharsBegin := SourceChars;

  DestBegin := pointer(Dest);

  {$endif}

  // first handle trailing 7 bit ASCII chars, by quad (Sha optimization)

  if SourceChars>=4 then

  repeat

    c := PCardinal(Source)^;

    if c and $80808080<>0 then

      break; // break on first non ASCII quad

    dec(SourceChars,4);

    inc(Source,4);

    PCardinal(Dest)^ := (c shl 8 or (c and $FF)) and $00ff00ff;

    c := c shr 16;

    PCardinal(Dest+2)^ := (c shl 8 or c) and $00ff00ff;

    inc(Dest,4);

  until SourceChars<4;

  if (SourceChars>0) and (ord(Source^)<128) then

  repeat

    dec(SourceChars);

    PWord(Dest)^ := ord(Source^); // much faster than dest^ := WideChar(c) for FPC

    inc(Source);

    inc(Dest);

  until (SourceChars=0) or (ord(Source^)>=128);

  // rely on the Operating System for all remaining ASCII characters

  if SourceChars=0 then

    result := Dest else begin

    {$ifdef MSWINDOWS}

    result := Dest+MultiByteToWideChar(

      fCodePage,MB_PRECOMPOSED,Source,SourceChars,Dest,SourceChars);

    {$else}

    {$ifdef ISDELPHIXE} // use cross-platform wrapper for MultiByteToWideChar()

    result := Dest+UnicodeFromLocaleChars(

      fCodePage,MB_PRECOMPOSED,Source,SourceChars,Dest,SourceChars);

    {$else}

    {$ifdef FPC}

    widestringmanager.Ansi2UnicodeMoveProc(Source,

      {$ifdef ISFPC27}fCodePage,{$endif}tmp,SourceChars);

    MoveFast(Pointer(tmp)^,Dest^,length(tmp)*2);

    result := Dest+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;

  result^ := #0;

end;



function TSynAnsiConvert.AnsiBufferToUTF8(Dest: PUTF8Char;

  Source: PAnsiChar; SourceChars: Cardinal): PUTF8Char;

var tmp: array[0..256*6] of WideChar;

    c: cardinal;

    U: PWideChar;

begin

  // first handle trailing 7 bit ASCII chars, by quad (Sha optimization)

  if SourceChars>=4 then

    repeat

      c := PCardinal(Source)^;

      if c and $80808080<>0 then

        break; // break on first non ASCII quad

      PCardinal(Dest)^ := c;

      dec(SourceChars,4);

      inc(Source,4);

      inc(Dest,4);

    until SourceChars<4;

  if (SourceChars>0) and (ord(Source^)<128) then

    repeat

      Dest^ := Source^;

      dec(SourceChars);

      inc(Source);

      inc(Dest);

    until (SourceChars=0) or (ord(Source^)>=128);

  // rely on the Operating System for all remaining ASCII characters

  if SourceChars=0 then

    result := Dest else

    if SourceChars<SizeOf(tmp)div 3 then

      result := Dest+RawUnicodeToUTF8(Dest,SourceChars*3,tmp,

        (PtrUInt(AnsiBufferToUnicode(tmp,Source,SourceChars))-PtrUInt(@tmp))shr 1) else begin

      GetMem(U,SourceChars*3+2);

      result := Dest+RawUnicodeToUtf8(Dest,SourceChars*3,U,

        AnsiBufferToUnicode(U,Source,SourceChars)-U);

      FreeMem(U);

    end;

  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/458259 -> 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

  tmp.Init(SourceChars*3+1);

  SourceChars := AnsiBufferToUTF8(tmp.buf,Source,SourceChars)-tmp.buf;

  W.Add(tmp.buf,SourceChars,Escape);

  tmp.Done;

end;



function TSynAnsiConvert.AnsiToRawUnicode(const AnsiText: RawByteString): RawUnicode;

begin

  result := AnsiToRawUnicode(pointer(AnsiText),length(AnsiText));

end;



procedure FastNewRawUTF8(var s: RawUTF8; len: integer);

{$ifdef FPC} inline;

begin

  SetString(s,nil,len);

end;

{$else}

{$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif}

begin

  if len<>0 then

    if (PtrUInt(s)=0) or                   // s=''

       (PInteger(PtrUInt(s)-8)^<>1) or     // s.refcount<>1

       (PInteger(PtrUInt(s)-4)^<>len) then // s.length<>len

      SetString(s,nil,len) else

      exit else

    if s='' then

      exit else

      s := '';

end;

{$else}

asm // eax=s edx=len

     test edx,edx

     mov ecx,[eax]

     jz System.@LStrClr

     test ecx,ecx

     jz @set

     cmp dword ptr [ecx-8],1

     jne @set

     cmp dword ptr [ecx-4],edx

     je @out

@set:mov ecx,edx

     xor edx,edx

{$ifdef UNICODE}

     push CP_UTF8 // UTF-8 code page for Delphi 2009+

     call  System.@LStrFromPCharLen // we need a call, not a jmp here

{$else}

     jmp System.@LStrFromPCharLen

{$endif}

@out:

end;

{$endif PUREPASCAL}

{$endif FPC}



function TSynAnsiConvert.AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode;

var U: PWideChar;

begin

  if SourceChars=0 then

    result := '' else begin

    SetString(result,nil,SourceChars*2+1);

    U := AnsiBufferToUnicode(pointer(result),Source,SourceChars);

    U^ := #0;

    SetLength(result,PtrUInt(U)-PtrUInt(result)+1);

  end;

end;



function TSynAnsiConvert.AnsiToUnicodeString(Source: PAnsiChar; SourceChars: Cardinal): SynUnicode;

var tmp: TSynTempBuffer;

    U: PWideChar;

begin

  if SourceChars=0 then

    result := '' else begin

    tmp.Init(SourceChars*2); // max dest size in bytes 

    U := AnsiBufferToUnicode(tmp.buf,Source,SourceChars);

    SetString(result,PWideChar(tmp.buf),(PtrUInt(U)-PtrUInt(tmp.buf))shr 1);

    tmp.Done;

  end;

end;



function TSynAnsiConvert.AnsiToUnicodeString(const Source: RawByteString): SynUnicode;

var tmp: TSynTempBuffer;

    U: PWideChar;

begin

  if Source='' then

    result := '' else begin

    tmp.Init(length(Source)*2); // max dest size in bytes 

    U := AnsiBufferToUnicode(tmp.buf,pointer(Source),length(Source));

    SetString(result,PWideChar(tmp.buf),(PtrUInt(U)-PtrUInt(tmp.buf))shr 1);

    tmp.Done;

  end;

end;



function TSynAnsiConvert.AnsiToUTF8(const AnsiText: RawByteString): RawUTF8;

begin

  result := AnsiBufferToRawUTF8(pointer(AnsiText),length(AnsiText));

end;



function TSynAnsiConvert.AnsiBufferToRawUTF8(Source: PAnsiChar; SourceChars: Cardinal): RawUTF8;

var tmp: TSynTempBuffer;

begin

  if (Source=nil) or (SourceChars=0) then

    result := '' else begin

    tmp.Init(SourceChars*3+1);

    SetString(result,PAnsiChar(tmp.buf),AnsiBufferToUTF8(tmp.buf,Source,SourceChars)-tmp.buf);

    tmp.Done;

  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);

end;



class function TSynAnsiConvert.Engine(aCodePage: cardinal): TSynAnsiConvert;

var i: integer;

begin

  if SynAnsiConvertList=nil then begin

    GarbageCollectorFreeAndNil(SynAnsiConvertList,TObjectList.Create);

    CurrentAnsiConvert := TSynAnsiConvert.Engine(GetACP);

    WinAnsiConvert := TSynAnsiConvert.Engine(CODEPAGE_US) as TSynAnsiFixedWidth;

    UTF8AnsiConvert := TSynAnsiConvert.Engine(CP_UTF8) as TSynAnsiUTF8;

  end;

  if aCodePage<=0 then begin

    result := CurrentAnsiConvert;

    exit;

  end;

  with SynAnsiConvertList do

    for i := 0 to Count-1 do begin

      result := List[i];

      if result.CodePage=aCodePage then

        exit;

    end;

  if aCodePage=CP_UTF8 then

    result := TSynAnsiUTF8.Create(CP_UTF8) else

  if aCodePage=CP_UTF16 then

    result := TSynAnsiUTF16.Create(CP_UTF16) else

  if IsFixedWidthCodePage(aCodePage) then

    result := TSynAnsiFixedWidth.Create(aCodePage) else

    result := TSynAnsiConvert.Create(aCodePage);

  SynAnsiConvertList.Add(result);

end;



function TSynAnsiConvert.UnicodeBufferToAnsi(Dest: PAnsiChar;

  Source: PWideChar; SourceChars: Cardinal): PAnsiChar;

var c: cardinal;

{$ifndef MSWINDOWS}

{$ifdef FPC}

    tmp: RawByteString;

{$endif}

{$ifdef KYLIX3}

    ic: iconv_t;

    DestBegin: PAnsiChar;

    SourceCharsBegin: integer;

{$endif}

{$endif MSWINDOWS}

begin

  {$ifdef KYLIX3}

  SourceCharsBegin := SourceChars;

  DestBegin := Dest;

  {$endif}

  // first handle trailing 7 bit ASCII chars, by pairs (Sha optimization)

  if SourceChars>=2 then

    repeat

      c := PCardinal(Source)^;

      if c and $ff80ff80<>0 then

        break; // break on first non ASCII pair

      dec(SourceChars,2);

      inc(Source,2);

      c := c shr 8 or c;

      PWord(Dest)^ := c;

      inc(Dest,2);

    until SourceChars<2;

  if (SourceChars>0) and (ord(Source^)<128) then

    repeat

      Dest^ := AnsiChar(ord(Source^));

      dec(SourceChars);

      inc(Source);

      inc(Dest);

    until (SourceChars=0) or (ord(Source^)>=128);

  // rely on the Operating System for all remaining ASCII characters

  if SourceChars=0 then

    result := Dest else begin

    {$ifdef MSWINDOWS}

    result := Dest+WideCharToMultiByte(

      fCodePage,0,Source,SourceChars,Dest,SourceChars*3,@DefaultCharVar,nil);

    {$else}

    {$ifdef ISDELPHIXE} // use cross-platform wrapper for WideCharToMultiByte()

    result := Dest+System.LocaleCharsFromUnicode(

      fCodePage,0,Source,SourceChars,Dest,SourceChars*3,@DefaultCharVar,nil);

    {$else}

    {$ifdef FPC}

    widestringmanager.Unicode2AnsiMoveProc(Source,tmp,

      {$ifdef ISFPC27}fCodePage,{$endif}SourceChars);

    MoveFast(Pointer(tmp)^,Dest^,length(tmp));

    result := Dest+length(tmp);

    {$else}

    {$ifdef KYLIX3}

    result := Dest; // makes compiler happy

    ic := LibC.iconv_open(Pointer(fIConvCodeName),'UTF-16LE');

    if PtrInt(ic)>=0 then

    try

      result := IconvBufConvert(ic,Source,SourceChars,2,

        Dest,SourceCharsBegin*3-(PAnsiChar(Dest)-DestBegin),1);

    finally

      LibC.iconv_close(ic);

    end else

    {$else}

    raise ESynException.CreateUTF8('%.UnicodeBufferToAnsi() not supported yet for CP=%',

      [self,CodePage]);    {$endif KYLIX3}

    {$endif FPC}

    {$endif ISDELPHIXE}

    {$endif MSWINDOWS}

  end;

end;



function TSynAnsiConvert.UTF8BufferToAnsi(Dest: PAnsiChar;

  Source: PUTF8Char; SourceChars: Cardinal): PAnsiChar;

var tmp: array[0..256*6] of WideChar;

    U: PWideChar;

begin

  if SourceChars<SizeOf(tmp)div 3 then

    result := UnicodeBufferToAnsi(Dest,tmp,UTF8ToWideChar(tmp,Source,SourceChars) shr 1) else begin

    Getmem(U,SourceChars*3+2);

    result := UnicodeBufferToAnsi(Dest,U,UTF8ToWideChar(U,Source,SourceChars) shr 1);

    Freemem(U);

  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);

    SetString(result,PAnsiChar(tmp.buf),Utf8BufferToAnsi(tmp.buf,Source,SourceChars)-tmp.buf);

    tmp.Done;

    {$ifdef HASCODEPAGE}

    SetCodePage(result,fCodePage,false);

    {$endif}

  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);

    SetString(result,PAnsiChar(tmp.buf),UnicodeBufferToAnsi(tmp.buf,Source,SourceChars)-tmp.buf);

    tmp.Done;

    {$ifdef HASCODEPAGE}

    SetCodePage(result,fCodePage,false);

    {$endif}

  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

    SetString(result,Source,SourceChars) else

  if (Source=nil) or (SourceChars=0) then

    result := '' else

  if SourceChars<sizeof(tmpU) shr 1 then

    result := UnicodeBufferToAnsi(tmpU,

      (PtrUInt(From.AnsiBufferToUnicode(tmpU,Source,SourceChars))-PtrUInt(@tmpU))shr 1) else begin

    GetMem(U,SourceChars*2+2);

    result := UnicodeBufferToAnsi(U,From.AnsiBufferToUnicode(U,Source,SourceChars)-U);

    FreeMem(U);

  end;

  {$ifdef HASCODEPAGE}

  SetCodePage(result,fCodePage,false);

  {$endif}

end;





{ TSynAnsiFixedWidth }



function TSynAnsiFixedWidth.AnsiBufferToUnicode(Dest: PWideChar;

  Source: PAnsiChar; SourceChars: Cardinal): PWideChar;

var i: Integer;

begin

  // PWord*(Dest)[] is much faster than dest^ := WideChar(c) for FPC

  for i := 1 to SourceChars shr 2 do begin

    PWordArray(Dest)[0] := fAnsiToWide[Ord(Source[0])];

    PWordArray(Dest)[1] := fAnsiToWide[Ord(Source[1])];

    PWordArray(Dest)[2] := fAnsiToWide[Ord(Source[2])];

    PWordArray(Dest)[3] := fAnsiToWide[Ord(Source[3])];

    inc(Source,4);

    inc(Dest,4);

  end;

  for i := 1 to SourceChars and 3 do begin

    PWord(Dest)^ := fAnsiToWide[Ord(Source^)];

    inc(Dest);

    inc(Source);

  end;

  Dest^ := #0;

  result := Dest;

end;



{$ifdef CPUARM} // circumvent FPC issue on ARM

function ToByte(value: cardinal): cardinal; inline;

begin

  result := value and $ff;

end;

{$else}

type ToByte = byte;

{$endif}



function TSynAnsiFixedWidth.AnsiBufferToUTF8(Dest: PUTF8Char;

  Source: PAnsiChar; SourceChars: Cardinal): 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 (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<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 (PtrUInt(Source) and 3=0) and (Source<=EndSourceBy4) then goto By4;

        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 (PtrUInt(Source) and 3=0) and (Source<=EndSourceBy4) then goto By4;

          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 (PtrUInt(Source) and 3=0) and (Source<EndSourceBy4) then goto By4;

          if Source<endSource then continue else break;

        end;

      end;

    until false;

  end;

  Dest^ := #0;

  Result := Dest;

end;



procedure TSynAnsiFixedWidth.InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal;

  DestTextWriter: TObject; Escape: TTextWriterKind);

begin

  TTextWriter(DestTextWriter).InternalAddFixedAnsi(Source,SourceChars,fAnsiToWide,Escape);

end;



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;



const

  /// used for fast WinAnsi to Unicode conversion

  // - this table contain all the unicode characters 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 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: integer;

    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 then begin // do not trust the Windows API :(

    for i := 0 to 255 do

      fAnsiToWide[i] := i;

    for i := low(WinAnsiUnicodeChars) to high(WinAnsiUnicodeChars) do

      fAnsiToWide[i] := WinAnsiUnicodeChars[i];

  end else begin // from Operating System returned values

    for i := 0 to 255 do

      A256[i] := AnsiChar(i);

    FillcharFast(U256,sizeof(U256),0);

    if PtrUInt(inherited AnsiBufferToUnicode(U256,A256,256))-PtrUInt(@U256)>512 then

      // ESynException.CreateUTF8() uses UTF8ToString() -> use CreateFmt() here

      raise ESynException.CreateFmt('OS error for %s.Create(%d)',[ClassName,aCodePage]);

    MoveFast(U256[0],fAnsiToWide[0],512);

  end;

  SetLength(fWideToAnsi,65536);

  for i := 1 to 126 do

    fWideToAnsi[i] := i;

  FillcharFast(fWideToAnsi[127],65536-127,ord('?')); // '?' for unknown char

  for i := 127 to 255 do

    if (fAnsiToWide[i]<>0) and (fAnsiToWide[i]<>ord('?')) then

      fWideToAnsi[fAnsiToWide[i]] := i;

  // fixed width Ansi will never be bigger than UTF-8

  fAnsiCharShift := 0;

end;



function TSynAnsiFixedWidth.IsValidAnsi(WideText: PWideChar; Length: integer): boolean;

var i: integer;

    wc: cardinal;

begin

  result := false;

  if WideText<>nil then

    for i := 0 to Length-1 do begin

      wc := cardinal(WideText[i]);

      if wc=0 then

        break else

      if wc<256 then

        if fAnsiToWide[wc]<256 then

          continue else

          exit else

          if fWideToAnsi[wc]=ord('?') then

            exit else

            continue;

    end;

  result := true;

end;



function TSynAnsiFixedWidth.IsValidAnsi(WideText: PWideChar): boolean;

var wc: cardinal;

begin

  result := false;

  if WideText<>nil then

    repeat

      wc := cardinal(WideText^);

      inc(WideText);

      if wc=0 then

        break else

      if wc<256 then

        if fAnsiToWide[wc]<256 then

          continue else

          exit else

          if fWideToAnsi[wc]=ord('?') then

            exit else

            continue;

    until false;

  result := true;

end;



function TSynAnsiFixedWidth.IsValidAnsiU(UTF8Text: PUTF8Char): boolean;

var c: cardinal;

    i, extra: integer;

begin

  result := false;

  if UTF8Text<>nil then

    repeat

      c := byte(UTF8Text^);

      inc(UTF8Text);

      if c=0 then break else

      if c and $80=0 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: Cardinal;

    i, extra: integer;

begin

  result := false;

  if UTF8Text<>nil then

    repeat

      c := byte(UTF8Text^);

      inc(UTF8Text);

      if c=0 then break else

      if c and $80=0 then

        continue else begin

        extra := UTF8_EXTRABYTES[c];

        if UTF8_EXTRA[extra].minimum>$ffff then

          exit;

        for i := 1 to extra do begin

          if byte(UTF8Text^) and $c0<>$80 then exit; // invalid UTF-8 content

          c := c shl 6+byte(UTF8Text^);

          inc(UTF8Text);

        end;

        dec(c,UTF8_EXTRA[extra].offset);

        if (c>255) or (fAnsiToWide[c]>255) then

          exit; // not 8 bit char (like "tm" or such) is marked invalid

      end;

    until false;

  result := true;

end;



function TSynAnsiFixedWidth.UnicodeBufferToAnsi(Dest: PAnsiChar;

  Source: PWideChar; SourceChars: Cardinal): PAnsiChar;

var c: cardinal;

begin

  // first handle trailing 7 bit ASCII chars, by pairs (Sha optimization)

  if SourceChars>=2 then

  repeat

    c := PCardinal(Source)^;

    if c and $ff80ff80<>0 then

      break; // break on first non ASCII pair

    dec(SourceChars,2);

    inc(Source,2);

    c := c shr 8 or c;

    PWord(Dest)^ := c;

    inc(Dest,2);

  until SourceChars<2;

  // use internal lookup tables for fast process of remaining chars

  for c := 1 to SourceChars shr 2 do begin

    Dest[0] := AnsiChar(fWideToAnsi[Ord(Source[0])]);

    Dest[1] := AnsiChar(fWideToAnsi[Ord(Source[1])]);

    Dest[2] := AnsiChar(fWideToAnsi[Ord(Source[2])]);

    Dest[3] := AnsiChar(fWideToAnsi[Ord(Source[3])]);

    inc(Source,4);

    inc(Dest,4);

  end;

  for c := 1 to SourceChars and 3 do begin

    Dest^ := AnsiChar(fWideToAnsi[Ord(Source^)]);

    inc(Dest);

    inc(Source);

  end;

  result := Dest;

end;



function TSynAnsiFixedWidth.UTF8BufferToAnsi(Dest: PAnsiChar;

  Source: PUTF8Char; SourceChars: Cardinal): PAnsiChar;

var c: cardinal;

    endSource, endSourceBy4: PUTF8Char;

    i,extra: integer;

label By1, By4, Quit; // ugly but faster

begin

  // first handle trailing 7 bit ASCII chars, by quad (Sha optimization)

  endSource := Source+SourceChars;

  endSourceBy4 := endSource-4;

  if (PtrUInt(Source) and 3=0) and (Source<=endSourceBy4) then

    repeat

By4:  c := PCardinal(Source)^;

      if c and $80808080<>0 then

        goto By1; // break on first non ASCII quad

      PCardinal(Dest)^ := c;

      inc(Source,4);

      inc(Dest,4);

    until Source>endSourceBy4;

  // generic loop, handling one UTF-8 code per iteration

  if Source<endSource then

    repeat

By1:  c := byte(Source^);

      inc(Source);

      if ord(c) and $80=0 then begin

        Dest^ := AnsiChar(c);

        inc(Dest);

        if (PtrUInt(Source) and 3=0) and (Source<=endSourceBy4) then goto By4;

        if Source<endSource then continue else break;

      end else begin

        extra := UTF8_EXTRABYTES[c];

        if (extra=0) or (Source+extra>endSource) 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 Source<endSource then continue else break;

      end;

    until false;

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): PWideChar;

begin

  result := Dest+(UTF8ToWideChar(Dest,PUTF8Char(Source),SourceChars) shr 1);

  result^ := #0;

end;



function TSynAnsiUTF8.AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar;

  SourceChars: Cardinal): PUTF8Char;

begin

  MoveFast(Source^,Dest^,SourceChars);

  result := Dest+SourceChars;

end;



procedure TSynAnsiUTF8.InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal;

  DestTextWriter: TObject; Escape: TTextWriterKind);

begin

  TTextWriter(DestTextWriter).Add(PUTF8Char(Source),SourceChars,Escape); 

end;



function TSynAnsiUTF8.AnsiToRawUnicode(Source: PAnsiChar;

  SourceChars: Cardinal): RawUnicode;

begin

  result := Utf8DecodeToRawUniCode(PUTF8Char(Source),SourceChars);

end;



constructor TSynAnsiUTF8.Create(aCodePage: cardinal);

begin

  if aCodePage<>CP_UTF8 then

    raise ESynException.CreateUTF8('%.Create(%)',[self,aCodePage]);

  inherited Create(aCodePage);

end;



function TSynAnsiUTF8.UnicodeBufferToAnsi(Dest: PAnsiChar;

  Source: PWideChar; SourceChars: Cardinal): PAnsiChar;

begin

  result := Dest+RawUnicodeToUTF8(PUTF8Char(Dest),SourceChars,Source,SourceChars);

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

  SetString(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

  SetString(Result,Source,SourceChars);

end;





{ TSynAnsiUTF16 }



function TSynAnsiUTF16.AnsiBufferToUnicode(Dest: PWideChar;

  Source: PAnsiChar; SourceChars: Cardinal): PWideChar;

begin

  MoveFast(Source^,Dest^,SourceChars);

  result := Pointer(PtrUInt(Dest)+SourceChars);

  result^ := #0;

end;



function TSynAnsiUTF16.AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar;

  SourceChars: Cardinal): PUTF8Char;

begin

  SourceChars := SourceChars shr 1; // from byte count to WideChar count

  result := Dest+RawUnicodeToUtf8(Dest,SourceChars*3,PWideChar(Source),SourceChars);

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);

end;





{ TSynTempBuffer }



procedure TSynTempBuffer.Init(const Source: RawByteString);

begin

  len := length(Source);

  if len=0 then

    buf := nil else begin

    if len<sizeof(tmp) then

      buf := @tmp else

      GetMem(buf,len+1); // +1 to include trailing #0

    MoveFast(pointer(Source)^,buf^,len+1); // +1 to include trailing #0

  end;

end;



procedure TSynTempBuffer.Init(Source: PUTF8Char);

begin

  len := StrLen(Source);

  if len=0 then

    buf := nil else begin

    if len<sizeof(tmp) then

      buf := @tmp else

      GetMem(buf,len+1); // +1 to include trailing #0

    MoveFast(Source^,buf^,len+1);

  end;

end;



procedure TSynTempBuffer.Init(Source: pointer; SourceLen: integer);

begin

  len := SourceLen;

  if len=0 then

    buf := nil else begin

    if len<sizeof(tmp) then

      buf := @tmp else

      GetMem(buf,len+1); // +1 to include trailing #0

    MoveFast(Source^,buf^,len+1);

  end;

end;



procedure TSynTempBuffer.Init(SourceLen: integer);

begin

  len := SourceLen;

  if len=0 then

    buf := nil else

    if len<sizeof(tmp) then

      buf := @tmp else

      GetMem(buf,len+1); // +1 to include trailing #0

end;



procedure TSynTempBuffer.Done;

begin

  if buf<>@tmp then

    if buf<>nil then

      FreeMem(buf);

end;





{ TSynTempWriter }



procedure TSynTempWriter.Init(maxsize: integer);

begin

  if maxsize<=0 then

    maxsize := sizeof(tmp.tmp)-1; // -1 for trailing #0

  tmp.Init(maxsize);

  pos := tmp.buf;

end;



procedure TSynTempWriter.Done;

begin

  tmp.Done;

end;



function TSynTempWriter.AsBinary: RawByteString;

begin

  SetString(result,PAnsiChar(tmp.buf),pos-tmp.buf);

end;



function TSynTempWriter.Position: integer;

begin

  result := pos-tmp.buf;

end;



procedure TSynTempWriter.wr(const val; len: integer);

begin

  if pos-tmp.buf+len>tmp.len then

     raise ESynException.CreateUTF8('TSynTempWriter(%) overflow',[tmp.len]);

  MoveFast(val,pos^,len);

  inc(pos,len);

end;



procedure TSynTempWriter.wrb(b: byte);

begin

  wr(b,1);

end;



procedure TSynTempWriter.wrint(int: integer);

begin

  wr(int,4);

end;



procedure TSynTempWriter.wrptrint(int: PtrInt);

begin

  wr(int,sizeof(int));

end;



procedure TSynTempWriter.wrptr(ptr: pointer);

begin

  wr(ptr,sizeof(ptr));

end;



procedure TSynTempWriter.wrss(const str: shortstring);

begin

  wr(str,ord(str[0])+1);

end;



procedure TSynTempWriter.wrw(w: word);

begin

  wr(w,2);

end;



function TSynTempWriter.wrfillchar(count: integer; value: byte): PAnsiChar;

begin

  if pos-tmp.buf+count>tmp.len then

     raise ESynException.CreateUTF8('TSynTempWriter(%) overflow',[tmp.len]);

  FillCharFast(pos^,count,value);

  result := pos;

  inc(pos,count);

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: integer);

var L: PtrInt;

begin

  L := length(S);

  if L<>0 then begin

    if L>=DestLen then

      L := DestLen-1; // truncate to avoid buffer overflow

    WinAnsiConvert.AnsiBufferToUnicode(PWideChar(Dest),pointer(S),L); // include last #0

  end else

    Dest^[0] := 0;

end;



function WinAnsiToRawUnicode(const S: WinAnsiString): RawUnicode;

begin

  result := WinAnsiConvert.AnsiToRawUnicode(S);

end;



function WinAnsiToUtf8(const S: WinAnsiString): RawUTF8;

begin

  result := WinAnsiConvert.AnsiBufferToRawUTF8(pointer(S),length(s));

end;



function WinAnsiToUtf8(WinAnsi: PAnsiChar; WinAnsiLen: integer): RawUTF8;

begin

  result := WinAnsiConvert.AnsiBufferToRawUTF8(WinAnsi,WinAnsiLen);

end;



function WideCharToWinAnsiChar(wc: cardinal): AnsiChar;

begin

  wc := WinAnsiConvert.WideCharToAnsiChar(wc);

  if integer(wc)=-1 then

    result := '?' else

    result := AnsiChar(wc);

end;



function WideCharToWinAnsi(wc: cardinal): integer;

begin

  result := WinAnsiConvert.WideCharToAnsiChar(wc);

end;



function IsWinAnsi(WideText: PWideChar; Length: integer): boolean;

begin

  result := WinAnsiConvert.IsValidAnsi(WideText,Length);

end;



function IsAnsiCompatible(PC: PAnsiChar): boolean;

begin

  result := false;

  if PC<>nil then

  while true do

    if PC^=#0 then

      break else

    if PC^<=#127 then

      inc(PC) else // 7 bits chars are always OK, whatever codepage/charset is used

      exit;

  result := true;

end;



function IsAnsiCompatible(PC: PAnsiChar; Len: integer): boolean;

var i: integer;

begin

  result := false;

  if PC<>nil then begin

    for i := 1 to Len shr 2 do

      if PCardinal(PC)^ and $80808080<>0 then

        exit else

        inc(PC,4);

    for i := 0 to (Len and 3)-1 do

      if PC[i]>=#127 then

        exit;

  end;

  result := true;

end;



function IsAnsiCompatible(const Text: RawByteString): boolean; overload;

begin

  result := IsAnsiCompatible(PAnsiChar(pointer(Text)),length(Text));

end;



function IsAnsiCompatible(PW: PWideChar): boolean; overload;

begin

  result := false;

  if PW<>nil then

  while true do

    if ord(PW^)=0 then

      break else

    if ord(PW^)<=127 then

      inc(PW) else // 7 bits chars are always OK, whatever codepage/charset is used

      exit;

  result := true;

end;



function IsAnsiCompatible(PW: PWideChar; Len: integer): boolean; overload;

var i: integer;

begin

  result := false;

  if PW<>nil then

    for i := 0 to Len-1 do

      if ord(PW[i])>127 then

        exit;

  result := true;

end;



function IsWinAnsi(WideText: PWideChar): boolean;

begin

  result := WinAnsiConvert.IsValidAnsi(WideText);

end;



function IsWinAnsiU(UTF8Text: PUTF8Char): boolean;

begin

  result := WinAnsiConvert.IsValidAnsiU(UTF8Text);

end;



function IsWinAnsiU8Bit(UTF8Text: PUTF8Char): boolean;

begin

  result := WinAnsiConvert.IsValidAnsiU8Bit(UTF8Text);

end;



function UTF8ToWinPChar(dest: PAnsiChar; source: PUTF8Char; count: integer): integer;

begin

  result := WinAnsiConvert.UTF8BufferToAnsi(dest,source,count)-dest;

end;



function ShortStringToAnsi7String(const source: shortstring): RawByteString;

begin

  SetString(result,PAnsiChar(@source[1]),ord(source[0]));

end;



procedure ShortStringToAnsi7String(const source: shortstring; var result: RawUTF8);

begin

  SetString(result,PAnsiChar(@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 and $80=0 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

  SetRawUTF8(result,P,StrLen(P));

end;



function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; MaxDestChars, sourceBytes: PtrInt): 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 and $80=0 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_EXTRABYTES[c];

    if (extra=0) or (Source+extra>endSource) 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<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  +UTF16_HISURROGATE_MIN;

    PWordArray(dest)[1] := c and $3FF+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:

  dest^ := #0; // always append a WideChar(0) to the end of the buffer

end;



function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; sourceBytes: PtrInt=0): 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 Source<endSource then

    repeat

By1:  c := byte(Source^); inc(Source);

      if c and $80=0 then begin

        PWord(dest)^ := c; // much faster than dest^ := WideChar(c) for FPC

        inc(dest);

        if (PtrUInt(Source) and 3=0) and (Source<=EndSourceBy4) then goto By4;

        if Source<endSource then continue else break;

      end;

      extra := UTF8_EXTRABYTES[c];

      if (extra=0) or (Source+extra>endSource) 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<minimum then

          break; // invalid input content

      end;

      if c<=$ffff then begin

        PWord(dest)^ := c;

        inc(dest);

        if (PtrUInt(Source) and 3=0) and (Source<=EndSourceBy4) then goto By4;

        if Source<endSource then continue else break;

      end;

      dec(c,$10000); // store as UTF-16 surrogates

      PWordArray(dest)[0] := c shr 10  +UTF16_HISURROGATE_MIN;

      PWordArray(dest)[1] := c and $3FF+UTF16_LOSURROGATE_MIN;

      inc(dest,2);

      if (PtrUInt(Source) and 3=0) and (Source<=EndSourceBy4) then goto By4;

      if Source>=endSource then break;

    until false;

Quit:

  result := PtrUInt(dest)-PtrUInt(begd); // dest-begd return char length

NoSource:

  dest^ := #0; // always append a WideChar(0) to the end of the buffer

end;



function IsValidUTF8(source: PUTF8Char): Boolean;

var extra, i: integer;

    c: cardinal;

begin

  result := false;

  if source<>nil then

  repeat

    c := byte(source^);

    inc(source);

    if c=0 then break else

    if c and $80<>0 then begin

      extra := UTF8_EXTRABYTES[c];

      if extra=0 then exit else // invalid leading byte

      for i := 1 to extra do

        if byte(source^) and $c0<>$80 then

          exit else

          inc(source); // check valid UTF-8 content

    end;

  until false;

  result := true;

end;



function 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

          exit else

          inc(source); // check valid UTF-8 content

    end;

  until false;

  result := true;

end;



function Utf8ToUnicodeLength(source: PUTF8Char): PtrUInt;

var c: byte;

    extra,i: integer;

begin

  result := 0;

  if source<>nil then

  repeat

    c := byte(source^);

    inc(source);

    if c=0 then break else

    if c and $80=0 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: byte;

    extra,i: integer;

    source: PUTF8Char;

begin

  source := pointer(text);

  if (source<>nil) and (cardinal(maxUtf16)<cardinal(length(text))) then

    repeat

      if maxUTF16<=0 then begin

        SetLength(text,source-pointer(text)); // truncate

        result := true;

        exit;

      end;

      c := byte(source^);

      inc(source);

      if c=0 then break else

      if c and $80=0 then

        dec(maxUTF16) else begin

        extra := UTF8_EXTRABYTES[c];

        if extra=0 then break else // invalid leading byte

        if extra>=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; maxUTF8: cardinal): boolean;

begin

  if cardinal(length(text))<maxUTF8 then begin

    result := false;

    exit; // nothing to truncate

  end;

  while (maxUTF8>0) and (ord(Text[maxUTF8]) and $c0=$80) do dec(maxUTF8);

  SetLength(text,maxUTF8);

  result := true;

end;



function Utf8FirstLineToUnicodeLength(source: PUTF8Char): PtrInt;

var c: byte;

    extra: Integer;

begin

  result := 0;

  if source<>nil then

  repeat

    c := byte(source^);

    inc(source);

    if c in [0,10,13] then break else // #0, #10 or #13 stop the count

    if c and $80=0 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; overload;

var short: array[0..256*6] of WideChar;

    U: PWideChar;

begin

  result := ''; // somewhat faster if result is freed before any SetLength()

  if L=0 then

    L := StrLen(P);

  if L=0 then

    exit;

  // +1 below is for #0 ending -> true WideChar(#0) ending

  if L<sizeof(short)div 3 then // mostly avoid tmp memory allocation on heap

    SetString(result,PAnsiChar(@short),UTF8ToWideChar(short,P,L)+1) else begin

    GetMem(U,L*3+2); // maximum posible unicode size (if all <#128)

    SetString(result,PAnsiChar(U),UTF8ToWideChar(U,P,L)+1);

    FreeMem(U);

  end;

end;



function Utf8DecodeToRawUnicode(const S: RawUTF8): RawUnicode; overload;

begin

  if S='' then

    result := '' else

    result := Utf8DecodeToRawUnicode(pointer(S),length(S));

end;



function Utf8DecodeToRawUnicodeUI(const S: RawUTF8; DestLen: PInteger=nil): 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; overload;

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): PtrInt; overload;

var c: Cardinal;

    Tail: PWideChar;

    i,j: integer;

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(Source);

    Tail := PWideChar(SourceLen)-2;

    if (PtrInt(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(Dest)>=DestLen);

    // generic loop, handling one UCS4 char per iteration

    if (PtrInt(Dest)<DestLen) and (PtrInt(Source)<SourceLen) then

    repeat

      // inlined UTF16CharToUtf8()

      c := cardinal(Source^);

      inc(Source);

      case c of

      0..$7f: begin

        Dest^ := AnsiChar(c);

        inc(Dest);

        if (PtrInt(Dest)<DestLen) and (PtrInt(Source)<SourceLen) then continue else break;

      end;

      UTF16_HISURROGATE_MIN..UTF16_HISURROGATE_MAX: begin

        if PtrInt(Source)>=SourceLen then break;

        c := ((c-$D7C0)shl 10)+(cardinal(Source^) xor UTF16_LOSURROGATE_MIN);

        inc(Source);

      end;

      UTF16_LOSURROGATE_MIN..UTF16_LOSURROGATE_MAX: begin

        if PtrInt(Source)>=SourceLen then break;

        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(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(Dest)<DestLen) and (PtrInt(Source)<SourceLen) then continue else break;

    until false;

    Dest^ := #0;

  end;

  result := PtrInt(Dest)-result;

end;



procedure RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer; var result: RawUTF8);

var tmp: TSynTempBuffer;

begin

  if (WideChar=nil) or (WideCharCount=0) then

    result := '' else begin

    tmp.Init(WideCharCount*3);

    SetRawUTF8(Result,tmp.buf,RawUnicodeToUtf8(tmp.buf,tmp.len+1,WideChar,WideCharCount));

    tmp.Done;

  end;

end;



function RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer): RawUTF8;

begin

  RawUnicodeToUTF8(WideChar,WideCharCount,result);

end;



function RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer; out UTF8Length: integer): RawUTF8; overload;

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);

  if UTF8Length<=0 then

    result := '';

end;



/// convert a RawUnicode string into a UTF-8 string

function RawUnicodeToUtf8(const Unicode: RawUnicode): RawUTF8;

begin

  RawUnicodeToUtf8(pointer(Unicode),length(Unicode) shr 1,result);

end;



function SynUnicodeToUtf8(const Unicode: SynUnicode): RawUTF8;

begin

  RawUnicodeToUtf8(pointer(Unicode),length(Unicode),result);

end;



function RawUnicodeToSynUnicode(const Unicode: RawUnicode): Synunicode;

begin

  SetString(result,PWideChar(pointer(Unicode)),length(Unicode) shr 1);

end;



function RawUnicodeToSynUnicode(WideChar: PWideChar; WideCharCount: integer): SynUnicode; overload;

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; overload;

begin

  result := WinAnsiConvert.UnicodeBufferToAnsi(WideChar,WideCharCount);

end;



function RawUnicodeToWinAnsi(const Unicode: RawUnicode): WinAnsiString;

begin

  result := WinAnsiConvert.UnicodeBufferToAnsi(pointer(Unicode),length(Unicode) shr 1);

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;



procedure AnsiCharToUTF8(P: PAnsiChar; L: Integer; var result: RawUTF8; ACP: integer);

begin

  result := TSynAnsiConvert.Engine(ACP).AnsiBufferToRawUTF8(P,L);

end;



{$ifdef HASVARUSTRING}

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 short: array[byte] of WideChar;

    U: PWideChar;

begin

  if (P=nil) or (L=0) then

    result := '' else

  if L<sizeof(short)div 3 then

    SetString(result,short,UTF8ToWideChar(short,P,L) shr 1) else begin

    GetMem(U,L*3+2); // maximum posible unicode size (if all <#128)

    SetString(result,U,UTF8ToWideChar(U,P,L) shr 1);

    FreeMem(U);

  end;

end;



function UnicodeStringToWinAnsi(const S: string): WinAnsiString;

begin

  result := RawUnicodeToWinAnsi(pointer(S),length(S));

end;



function UTF8DecodeToUnicodeString(P: PUTF8Char; L: integer): UnicodeString;

begin

  UTF8DecodeToUnicodeString(P,L,result);

end;



function WinAnsiToUnicodeString(WinAnsi: PAnsiChar; WinAnsiLen: integer): 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}



{$ifdef UNICODE}

function Ansi7ToString(const Text: RawByteString): string;

var i: integer;

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;

{$else}

function Ansi7ToString(const Text: RawByteString): string;

begin

  result := Text; // if we are SURE this text is 7 bit Ansi -> direct assign

end;

{$endif}



{$ifdef UNICODE}

function Ansi7ToString(Text: PWinAnsiChar; Len: integer): string;

begin

  Ansi7ToString(Text,Len,result);

end;

{$else}

function Ansi7ToString(Text: PWinAnsiChar; Len: integer): string;

begin

  SetString(result,PAnsiChar(Text),Len);

end;

{$endif}



{$ifdef UNICODE}

procedure Ansi7ToString(Text: PWinAnsiChar; Len: integer; var result: string);

var i: integer;

begin

  SetString(result,nil,Len);

  for i := 0 to Len-1 do

    PWordArray(result)[i] := PByteArray(Text)[i]; // no conversion for 7 bit Ansi

end;

{$else}

procedure Ansi7ToString(Text: PWinAnsiChar; Len: integer; var result: string);

begin

  SetString(result,PAnsiChar(Text),Len);

end;

{$endif}



{$ifdef UNICODE}

function StringToAnsi7(const Text: string): RawByteString;

var i: integer;

begin

  SetString(result,nil,length(Text));

  for i := 0 to length(Text)-1 do

    PByteArray(result)[i] := PWordArray(Text)[i]; // no conversion for 7 bit Ansi

end;

{$else}

function StringToAnsi7(const Text: string): RawByteString;

begin

  result := Text; // if we are SURE this text is 7 bit Ansi -> direct assign

end;

{$endif}



{$ifdef UNICODE}

function StringToWinAnsi(const Text: string): WinAnsiString;

begin

  result := RawUnicodeToWinAnsi(Pointer(Text),length(Text));

end;

{$else}

function StringToWinAnsi(const Text: string): WinAnsiString;

begin

  result := WinAnsiConvert.AnsiToAnsi(CurrentAnsiConvert,Text);

end;

{$endif}



{$ifdef UNICODE}

function StringBufferToUtf8(Dest: PUTF8Char; Source: PChar; SourceChars: PtrInt): PUTF8Char;

begin

  result := Dest+RawUnicodeToUtf8(Dest,SourceChars*3,PWideChar(Source),SourceChars);

end;

{$else}

function StringBufferToUtf8(Dest: PUTF8Char; Source: PChar; SourceChars: PtrInt): PUTF8Char;

begin

  result := CurrentAnsiConvert.AnsiBufferToUTF8(Dest,Source,SourceChars);

end;

{$endif}



{$ifdef UNICODE}

function StringToUTF8(const Text: string): RawUTF8;

begin

  RawUnicodeToUtf8(pointer(Text),length(Text),result);

end;

{$else}

function StringToUTF8(const Text: string): RawUTF8;

begin

  result := CurrentAnsiConvert.AnsiToUTF8(Text);

end;

{$endif}



{$ifdef UNICODE}

procedure StringToUTF8(const Text: string; var result: RawUTF8);

begin

  RawUnicodeToUtf8(pointer(Text),length(Text),result);

end;

{$else}

procedure StringToUTF8(const Text: string; var result: RawUTF8);

begin

  result := CurrentAnsiConvert.AnsiToUTF8(Text);

end;

{$endif}



{$ifdef UNICODE}

function ToUTF8(const Text: string): RawUTF8;

begin

  RawUnicodeToUtf8(pointer(Text),length(Text),result);

end;

{$else}

function ToUTF8(const Text: string): RawUTF8;

begin

  result := CurrentAnsiConvert.AnsiToUTF8(Text);

end;

{$endif}



function ToUTF8(const Ansi7Text: ShortString): RawUTF8;

begin

  SetString(result,PAnsiChar(@Ansi7Text[1]),ord(Ansi7Text[0]));

end;



function ToUTF8(const guid: TGUID): RawUTF8;

begin

  FastNewRawUTF8(result,36);

  GUIDToText(pointer(result),@guid);

end;



procedure Int32ToUTF8(Value : integer; var result: RawUTF8);

var tmp: array[0..15] of AnsiChar;

    P: PAnsiChar;

begin

  P := StrInt32(@tmp[15],Value);

  SetRawUTF8(result,P,@tmp[15]-P);

end;



procedure Int64ToUtf8(Value: Int64; var result: RawUTF8);

var tmp: array[0..23] of AnsiChar;

    P: PAnsiChar;

begin

  P := StrInt64(@tmp[23],Value);

  SetRawUTF8(result,P,@tmp[23]-P);

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:   value := V.VInt64^;

    vtBoolean: if V.VBoolean then

                 value := 1 else

                 value := 0;

    {$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^;

    vtBoolean: if V.VBoolean then

                 value := 1 else

                 value := 0;

    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 tmpStr: RawUTF8; var Res: TTempUTF8): integer;

{$ifndef NOVARIANTS}

var isString: boolean;

{$endif}

begin

  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)),tmpStr);

    {$endif}

    vtWideString:

      RawUnicodeToUtf8(V.VPWideChar,length(WideString(V.VWideString)),tmpStr);

    vtPChar: begin

      Res.Text := V.VPointer;

      Res.Len := StrLen(V.VPointer);

      result := Res.Len;

      exit;

    end;

    vtChar: begin

      {$ifdef FPC} // alf: to circumvent FPC issues

      RawUnicodeToUtf8(@V.VChar,1,tmpStr);

      {$else}

      Res.Text := @V.VChar;

      Res.Len := 1;

      result := 1;

      exit;

      {$endif}

    end;

    vtPWideChar:

      RawUnicodeToUtf8(V.VPWideChar,StrLenW(V.VPWideChar),tmpStr);

    vtWideChar:

      RawUnicodeToUtf8(@V.VWideChar,1,tmpStr);

    vtBoolean: begin

      Res.Temp[0] := AnsiChar(ord(V.VBoolean)+48);

      Res.Text := @Res.Temp;

      Res.Len := 1;

      result := 1;

      exit;

    end;

    vtInteger: begin

      Res.Text := PUTF8Char(StrInt32(@Res.Temp[23],V.VInteger));

      Res.Len := @Res.Temp[23]-Res.Text;

      result := Res.Len;

      exit;

    end;

    vtInt64: begin

      Res.Text := PUTF8Char(StrInt64(@Res.Temp[23],V.VInt64^));

      Res.Len := @Res.Temp[23]-Res.Text;

      result := Res.Len;

      exit;

    end;

    vtCurrency: begin

      Res.Text := @Res.Temp;

      Res.Len := Curr64ToPChar(V.VInt64^,Res.Temp);

      result := Res.Len;

      exit;

    end;

    vtExtended:

      ExtendedToStr(V.VExtended^,DOUBLE_PRECISION,tmpStr);

    vtPointer,vtInterface: begin

      Res.Text := @Res.Temp;

      Res.Len := sizeof(pointer)*2;

      BinToHexDisplay(V.VPointer,@Res.Temp,sizeof(Pointer));

      result := sizeof(pointer)*2;

      exit;

    end;

    vtClass: begin

      if V.VClass<>nil then begin

        Res.Text := PUTF8Char(PPointer(PtrInt(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 := PUTF8Char(PPointer(PPtrInt(V.VObject)^+vmtClassName)^)+1;

        Res.Len := ord(Res.Text[-1]);

      end else

        Res.Len := 0;

      result := Res.Len;

      exit;

    end;

    {$ifndef NOVARIANTS}

    vtVariant:

      VariantToUTF8(V.VVariant^,tmpStr,isString);

    {$endif}

    else begin

      Res.Len := 0;

      result := 0;

      exit;

    end;

  end;

  Res.Text := pointer(tmpStr);

  Res.Len := length(tmpStr);

  result := Res.Len;

end;



procedure VarRecToUTF8(const V: TVarRec; var result: RawUTF8; wasString: PBoolean=nil);

var isString: boolean;

begin

  isString := not (V.VType in [vtBoolean,vtInteger,vtInt64,vtCurrency,vtExtended]);

  with V do

  case V.VType of

    vtString:

      SetRawUTF8(result,@VString^[1],ord(VString^[0]));

    vtAnsiString:

      result := RawUTF8(VAnsiString); // expect UTF-8 content

    {$ifdef HASVARUSTRING}

    vtUnicodeString:

      result := UnicodeStringToUtf8(UnicodeString(VUnicodeString));

    {$endif}

    vtWideString:

      RawUnicodeToUtf8(VWideString,length(WideString(VWideString)),result);

    vtPChar:

      SetRawUTF8(result,VPChar,StrLen(VPChar));

    vtChar:

      SetRawUTF8(result,PAnsiChar(@VChar),1);

    vtPWideChar:

      RawUnicodeToUtf8(VPWideChar,StrLenW(VPWideChar),result);

    vtWideChar:

      RawUnicodeToUtf8(@VWideChar,1,result);

    vtBoolean:

      if VBoolean then result := '1' else result := '0';

    vtInteger:

      Int32ToUtf8(VInteger,result);

    vtInt64:

      Int64ToUtf8(VInt64^,result);

    vtCurrency:

      Curr64ToStr(VInt64^,result);

    vtExtended:

      ExtendedToStr(VExtended^,DOUBLE_PRECISION,result);

    vtPointer:

      PointerToHex(VPointer,result);

    vtClass:

      if VClass<>nil then                                          

        result := PShortString(PPointer(PtrInt(VClass)+vmtClassName)^)^ else

        result := '';

    vtObject:

       if VObject<>nil then

         result := PShortString(PPointer(PPtrInt(VObject)^+vmtClassName)^)^ else

         result := '';

    vtInterface:

      {$ifdef HASINTERFACEASTOBJECT}

      if VInterface<>nil then

        result := PShortString(PPointer(PPtrInt(IInterface(VInterface) as TObject)^+vmtClassName)^)^ else

        result := '';

      {$else}

      PointerToHex(VInterface,result);

      {$endif}

    {$ifndef NOVARIANTS}

    vtVariant:

      VariantToUTF8(VVariant^,result,isString);

    {$endif}

    else begin

      isString := false;

      result := '';

    end;

  end;

  if wasString<>nil then

    wasString^ := isString;

end;



function VarRecToUTF8IsString(const V: TVarRec; var value: RawUTF8): boolean;

begin

  VarRecToUTF8(V,value,@result);

end;



procedure VarRecToInlineValue(const V: TVarRec; var result: RawUTF8);

var wasString: boolean;

begin

  VarRecToUTF8(V,result,@wasString);

  if wasString then

    result := QuotedStr(pointer(result),'"');

end;



{$ifdef UNICODE}

function StringToRawUnicode(const S: string): RawUnicode;

begin

  SetString(result,PAnsiChar(pointer(S)),length(S)*2+1); // +1 for last wide #0

end;

{$else}

function StringToRawUnicode(const S: string): RawUnicode;

begin

  result := CurrentAnsiConvert.AnsiToRawUnicode(S);

end;

{$endif}



{$ifdef UNICODE}

function StringToSynUnicode(const S: string): SynUnicode;

begin

  result := S;

end;

{$else}

function StringToSynUnicode(const S: string): SynUnicode;

begin

  result := CurrentAnsiConvert.AnsiToUnicodeString(pointer(S),length(S));

end;

{$endif}



{$ifdef UNICODE}

function StringToRawUnicode(P: PChar; L: integer): RawUnicode;

begin

  SetString(result,PAnsiChar(P),L*2+1); // +1 for last wide #0

end;

{$else}

function StringToRawUnicode(P: PChar; L: integer): RawUnicode;

begin

  result := CurrentAnsiConvert.AnsiToRawUnicode(P,L);

end;

{$endif}





{$ifdef UNICODE}

function RawUnicodeToString(P: PWideChar; L: integer): string; overload;

begin

  SetString(result,P,L);

end;

{$else}

function RawUnicodeToString(P: PWideChar; L: integer): string; overload;

begin

  result := CurrentAnsiConvert.UnicodeBufferToAnsi(P,L);

end;

{$endif}



{$ifdef UNICODE}

procedure RawUnicodeToString(P: PWideChar; L: integer; var result: string); overload;

begin

  SetString(result,P,L);

end;

{$else}

procedure RawUnicodeToString(P: PWideChar; L: integer; var result: string); overload;

begin

  result := CurrentAnsiConvert.UnicodeBufferToAnsi(P,L);

end;

{$endif}



{$ifdef UNICODE}

function RawUnicodeToString(const U: RawUnicode): string;

begin // uses StrLenW() and not length(U) to handle case when was used as buffer

  SetString(result,PWideChar(pointer(U)),StrLenW(Pointer(U)));

end;

{$else}

function RawUnicodeToString(const U: RawUnicode): string;

begin // uses StrLenW() and not length(U) to handle case when was used as buffer

  result := CurrentAnsiConvert.UnicodeBufferToAnsi(Pointer(U),StrLenW(Pointer(U)));

end;

{$endif}



{$ifdef UNICODE}

function SynUnicodeToString(const U: SynUnicode): string;

begin

  result := U;

end;

{$else}

function SynUnicodeToString(const U: SynUnicode): string;

begin

  result := CurrentAnsiConvert.UnicodeBufferToAnsi(Pointer(U),length(U));

end;

{$endif}



{$ifdef UNICODE}

function UTF8DecodeToString(P: PUTF8Char; L: integer): string;

begin

  UTF8DecodeToUnicodeString(P,L,result);

end;

{$else}

function UTF8DecodeToString(P: PUTF8Char; L: integer): string;

begin

  CurrentAnsiConvert.UTF8BufferToAnsi(P,L,RawByteString(result));

end;

{$endif}



{$ifdef UNICODE}

procedure UTF8DecodeToString(P: PUTF8Char; L: integer; var result: string);

begin

  UTF8DecodeToUnicodeString(P,L,result);

end;

{$else}

procedure UTF8DecodeToString(P: PUTF8Char; L: integer; var result: string);

begin

  CurrentAnsiConvert.UTF8BufferToAnsi(P,L,RawByteString(result));

end;

{$endif}



{$ifdef UNICODE}

function UTF8ToString(const Text: RawUTF8): string;

begin

  UTF8DecodeToUnicodeString(pointer(Text),length(Text),result);

end;

{$else}

function UTF8ToString(const Text: RawUTF8): string;

begin

  CurrentAnsiConvert.UTF8BufferToAnsi(pointer(Text),length(Text),RawByteString(result));

end;

{$endif}



function UTF8ToWideString(const Text: RawUTF8): WideString;

begin

{$ifdef FPC}

  result := '';

{$endif}

  UTF8ToWideString(Text,result);

end;



procedure UTF8ToWideString(const Text: RawUTF8; var result: WideString);

begin

  UTF8ToWideString(pointer(Text),Length(Text),result);

end;



procedure UTF8ToWideString(Text: PUTF8Char; Len: integer; var result: WideString); overload;

var short: array[0..256*6] of WideChar;

    U: PWideChar;

begin

  if (Text=nil) or (Len=0) then

    result := '' else

  if Len<sizeof(short)div 3 then

    SetString(result,short,UTF8ToWideChar(short,Text,Len) shr 1) else begin

    GetMem(U,Len*3+2); // maximum posible unicode size (if all <#128)

    SetString(result,U,UTF8ToWideChar(U,Text,Len) shr 1);

    FreeMem(U);

  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); overload;

begin

  UTF8ToSynUnicode(pointer(Text),length(Text),result);

end;



procedure UTF8ToSynUnicode(Text: PUTF8Char; Len: integer; var result: SynUnicode); overload;

var short: array[byte] of WideChar;

    U: PWideChar;

begin

  if (Text=nil) or (Len=0) then

    result := '' else

  if Len<sizeof(short)div 3 then

    SetString(result,short,UTF8ToWideChar(short,Text,Len) shr 1) else begin

    GetMem(U,Len*3+2); // maximum posible unicode size (if all <#128)

    SetString(result,U,UTF8ToWideChar(U,Text,Len) shr 1);

    FreeMem(U);

  end;

end;



function StrInt32(P: PAnsiChar; val: PtrInt): PAnsiChar;

{$ifdef CPU64}

{$ifdef FPC}

begin // fallback to pure pascal version, since asm version below make GPFs for FPC

  if val<0 then begin

    result := StrUInt32(P,PtrUInt(-val))-1;

    result^ := '-';

  end else

    result := StrUInt32(P,val);

end;

{$else}

{$ifdef FPC}nostackframe; assembler;

asm

{$else}

asm // rcx=P, rdx=val (Linux: rdi,rsi)

    .NOFRAME

{$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,TwoDigitLookup

@s: cmp rax,100

    lea rcx,[rcx-2]

    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;

{$endif FPC}

{$else}

{$ifdef PUREPASCAL}

begin // this code is faster than the Borland's original str() or IntToStr()

  if val<0 then begin

    result := StrUInt32(P,PtrUInt(-val))-1;

    result^ := '-';

  end else

    result := StrUInt32(P,val);

end;

{$else}

asm // eax=P, edx=val

    mov ecx,edx

    sar ecx,31         // 0 if val>=0 or -1 if val<0

    push ecx

    xor edx,ecx

    sub edx,ecx        // edx=abs(val)

    cmp edx,10; jb @3  // direct process of common val<10

    push edi

    mov edi,eax

    mov eax,edx

    //nop; nop           // for loop alignment

@s: cmp eax,100

    lea edi,[edi-2]

    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

    lea eax,[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

    lea eax,[eax+ecx] // includes '-' if val<0

    ret

@3: dec eax

    pop ecx

    or dl,'0'

    mov byte ptr [eax-1],'-'

    mov [eax],dl

    lea eax,[eax+ecx] // includes '-' if val<0

end;

{$endif CPU64}

{$endif PUREPASCAL}



function StrUInt32(P: PAnsiChar; val: PtrUInt): PAnsiChar;

{$ifdef CPUX64}

{$ifdef FPC}nostackframe; assembler;

asm

{$else}

asm // rcx=P, rdx=val (Linux: rdi,rsi)

    .NOFRAME

{$endif FPC}

    {$ifndef win64}

    mov rcx,rdi

    mov rdx,rsi

    {$endif win64}

    cmp rdx,10; jb @3           // direct process of common val<10

    mov rax,rdx

    lea r8, [rip+TwoDigitLookup]

@s: cmp rax,100

    lea rcx,[rcx-2]

    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: 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 PUREPASCAL}

var c100: PtrUInt;

begin // this code is faster than the Borland's original str() or IntToStr()

  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)^ := TwoDigitLookupW[val];

      break;

    end;

    dec(P,2);

    c100 := val div 100;

    dec(val,c100*100);

    PWord(P)^ := TwoDigitLookupW[val];

    val := c100;

    if c100=0 then break;

  until false;

  result := P;

end;

{$else}

asm // eax=P, edx=val

    cmp edx,10; jb @3  // direct process of common val=0 (or val<10)

    push edi

    mov edi,eax

    mov eax,edx

    nop; nop           // for loop alignment

@s: cmp eax,100

    lea edi,[edi-2]

    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 PUREPASCAL}



function StrUInt64(P: PAnsiChar; const val: QWord): PAnsiChar;

{$ifdef CPU64}

begin // StrUInt32 aldready implemented PtrUInt=UInt64

  result := StrUInt32(P,val);

end;

{$else}

var c,c100: QWord;

begin

  if Int64Rec(val).Hi=0 then

    P := StrUInt32(P,Int64Rec(val).Lo) else begin

    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)^ := TwoDigitLookupW[c];

      c := c100;

      if Int64Rec(c).Hi=0 then begin

        if Int64Rec(c).Lo<>0 then

          P := StrUInt32(P,Int64Rec(c).Lo);

        break;

      end;

    until false;

  end;

  result := P;

end;

{$endif}



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;



const

  // see https://en.wikipedia.org/wiki/Baudot_code

  B2A: 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

  A2B: array[AnsiChar] of byte;



function AsciiToBaudot(const Text: RawUTF8): RawByteString;

begin

  result := AsciiToBaudot(pointer(Text),length(Text));

end;



function AsciiToBaudot(P: PAnsiChar; len: integer): RawByteString; overload;

var i,c,d,bits: integer;

    shift: boolean;

    dest: PByte;

    tmp: TSynTempBuffer;

begin

  result := '';

  if (P=nil) or (len=0) then

    exit;

  shift := false;

  tmp.Init((len*10)shr 3);

  dest := tmp.buf;

  d := 0;

  bits := 0;

  for i := 0 to len-1 do begin

    c := A2B[P[i]];

    if c>32 then begin

      if not shift then begin

        d := (d shl 5) or 27;

        inc(bits,5);

        shift := true;

      end;

      d := (d shl 5) or (c-32);

      inc(bits,5);

    end else

    if c>0 then begin

      if shift and (P[i]>=' ') then begin

        d := (d shl 5) or 31;

        inc(bits,5);

        shift := false;

      end;

      d := (d shl 5) or c;

      inc(bits,5);

    end;

    while bits>=8 do begin

      dec(bits,8);

      dest^ := d shr bits;

      inc(dest);

    end;

  end;

  if bits>0 then begin

    dest^ := d shl (8-bits);

    inc(dest);

  end;

  SetString(result,PAnsiChar(tmp.buf),PAnsiChar(dest)-PAnsiChar(tmp.buf));

  tmp.Done;

end;



function BaudotToAscii(const Baudot: RawByteString): RawUTF8;

begin

  result := BaudotToAscii(pointer(Baudot),length(Baudot));

end;



function BaudotToAscii(Baudot: PByteArray; len: integer): RawUTF8; overload;

var i,c,b,bits,shift: integer;

    tmp: TSynTempBuffer;

    dest: PAnsiChar;

begin

  result := '';

  if (Baudot=nil) or (len=0) then

    exit;

  tmp.Init((len*8)div 5+1);

  dest := tmp.buf;

  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(B2A[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;

  SetString(result,PAnsiChar(tmp.buf),dest-PAnsiChar(tmp.buf));

  tmp.Done;

end;



{$ifdef CPU64}

procedure Exchg16(P1,P2: PInt64Array);

var c: Int64;

begin

  c := P1[0];

  P1[0] := P2[0];

  P2[0] := c;

  c := P1[1];

  P1[1] := P2[1];

  P2[1] := c;

end;

{$else}

procedure Exchg16(P1,P2: PIntegerArray);

var c: integer;

begin

  c := P1[0];

  P1[0] := P2[0];

  P2[0] := c;

  c := P1[1];

  P1[1] := P2[1];

  P2[1] := c;

  c := P1[2];

  P1[2] := P2[2];

  P2[2] := c;

  c := P1[3];

  P1[3] := P2[3];

  P2[3] := c;

end;

{$endif}



procedure Exchg(P1,P2: PAnsiChar; count: PtrInt);

{$ifdef PUREPASCAL}

var i, c: PtrInt;

    u: AnsiChar;

begin

  for i := 1 to count shr POINTERSHR do begin

    c := PPtrInt(P1)^;

    PPtrInt(P1)^ := PPtrInt(P2)^;

    PPtrInt(P2)^ := c;

    inc(P1,SizeOf(c));

    inc(P2,SizeOf(c));

  end;

  for i := 0 to (count and pred(sizeof(c)))-1 do begin

    u := P1[i];

    P1[i] := P2[i];

    P2[i] := u;

  end;

end;

{$else}

asm // eax=P1, edx=P2, ecx=count

   push ebx

   push esi

   push ecx

   shr ecx,2

   jz @2

@4:dec ecx

   mov ebx,[eax]

   mov esi,[edx]

   mov [eax],esi

   mov [edx],ebx

   lea eax,[eax+4]

   lea edx,[edx+4]

   jnz @4

@2:pop ecx

   and ecx,3

   jz @0

@1:dec ecx

   mov bl,[eax]

   mov bh,[edx]

   mov [eax],bh

   mov [edx],bl

   lea eax,[eax+1]

   lea edx,[edx+1]

   jnz @1

@0:pop esi

   pop ebx

end;

{$endif}



{$ifdef FPC}



type

  /// available type families for Free Pascal RTTI values

  // - values differs from Delphi, and are taken from FPC typinfo.pp unit

  // - here below, we defined tkLString instead of FPC tkAString to match

  // Delphi - see http://lists.freepascal.org/fpc-devel/2013-June/032233.html

  TTypeKind = (tkUnknown,tkInteger,tkChar,tkEnumeration,tkFloat,

    tkSet,tkMethod,tkSString,tkLStringOld,tkLString,

    tkWString,tkVariant,tkArray,tkRecord,tkInterface,

    tkClass,tkObject,tkWChar,tkBool,tkInt64,tkQWord,

    tkDynArray,tkInterfaceRaw,tkProcVar,tkUString,tkUChar,tkHelper);



const

   // all potentially managed types

   tkManagedTypes = [tkLStringOld,tkLString,tkWstring,tkUstring,tkArray,

                     tkObject,tkRecord,tkDynArray,tkInterface,tkVariant];

   // maps record or object types

   tkRecordTypes = [tkObject,tkRecord];

   tkRecordTypeOrSet = [tkObject,tkRecord];



type

  TDelphiTypeKind = (dkUnknown, dkInteger, dkChar, dkEnumeration, dkFloat,

    dkString, dkSet, dkClass, dkMethod, dkWChar, dkLString, dkWString,

    dkVariant, dkArray, dkRecord, dkInterface, dkInt64, dkDynArray,

    dkUString, dkClassRef, dkPointer, dkProcedure);



const

  FPCTODELPHI: array[TTypeKind] of TDelphiTypeKind = (

    dkUnknown,dkInteger,dkChar,dkEnumeration,dkFloat,

    dkSet,dkMethod,dkString,dkLString,dkLString,

    dkWString,dkVariant,dkArray,dkRecord,dkInterface,

    dkClass,dkRecord,dkWChar,dkEnumeration,dkInt64,dkInt64,

    dkDynArray,dkInterface,dkProcedure,dkUString,dkWChar,dkPointer);

  DELPHITOFPC: array[TDelphiTypeKind] of TTypeKind = (

    tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,

    tkSString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString,

    tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray,

    tkUString, tkProcVar, tkProcVar, tkProcVar);



{$else}



type

  /// available type families for Delphi 6 and up, similar to typinfo.pas

  TTypeKind = (tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,

    tkString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString,

    tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray

    {$ifdef UNICODE}, tkUString, tkClassRef, tkPointer, tkProcedure{$endif});



const

  // maps record or object types

  tkRecordTypes = [tkRecord];

  tkRecordTypeOrSet = tkRecord;



{$endif}



type

  TOrdType = (otSByte,otUByte,otSWord,otUWord,otSLong,otULong);

  TFloatType = (ftSingle,ftDoub,ftExtended,ftComp,ftCurr);

  TTypeKinds = set of TTypeKind;

  PTypeKind = ^TTypeKind;



  PStrRec = ^TStrRec;

  /// map the Delphi/FPC string header, as defined in System.pas

  TStrRec =

    {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}

    packed

    {$endif FPC_REQUIRES_PROPER_ALIGNMENT}

    record

{$ifdef FPC}

  {$ifdef ISFPC27}

    codePage: Word;

    elemSize: Word;

  {$endif}

  {$ifdef CPU64}

    _Padding: LongInt;

  {$endif}

    refCnt: SizeInt;

    length: SizeInt;

{$else FPC}

  {$ifdef UNICODE}

    {$ifdef CPU64}

    /// padding bytes for 16 byte alignment of the header

    _Padding: LongInt;

    {$endif}

    /// the associated code page used for this string

    // - exist only since Delphi/FPC 2009

    // - 0 or 65535 for RawByteString

    // - 1200=CP_UTF16 for UnicodeString

    // - 65001=CP_UTF8 for RawUTF8

    // - the current code page for AnsiString

    codePage: Word;

    /// either 1 (for AnsiString) or 2 (for UnicodeString)

    // - exist only since Delphi/FPC 2009

    elemSize: Word;

  {$endif UNICODE}

    /// COW string reference count (basic garbage memory mechanism)

    refCnt: Longint;

    /// length in characters

    // - size in bytes = length*elemSize

    length: Longint;

{$endif FPC}

  end;



  /// map the Delphi/FPC dynamic array header (stored before each instance)

  TDynArrayRec = packed record

    /// dynamic array reference count (basic garbage memory mechanism)

    {$ifdef FPC}

    refCnt: PtrInt;

    high: tdynarrayindex;

    function GetLength: sizeint; inline;

    procedure SetLength(len: sizeint); inline;

    property length: sizeint read GetLength write SetLength;

    {$else}

    {$ifdef CPUX64}

    _Padding: LongInt; // Delphi/FPC XE2+ expects 16 byte alignment

    {$endif}

    refCnt: Longint;

    /// length in element count

    // - size in bytes = length*ElemSize

    length: PtrInt;

    {$endif}

  end;

  PDynArrayRec = ^TDynArrayRec;



  {$ifdef FPC}

    {$PACKRECORDS C}

  {$endif FPC}



  PTypeInfo = ^TTypeInfo;

  {$ifdef HASDIRECTTYPEINFO}

  PTypeInfoStored = PTypeInfo;

  {$else}

  PTypeInfoStored = ^PTypeInfo;

  {$endif}



  /// 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;

  {$ifdef ISDELPHI2010}

  /// map the Delphi record field enhanced RTTI (available since Delphi 2010)

  TEnhancedFieldInfo = packed record

    TypeInfo: PTypeInfoStored;

    Offset: PtrUInt;

    Flags: Byte;

    NameLen: byte; // = Name[0] = length(Name)

  end;

  PEnhancedFieldInfo = ^TEnhancedFieldInfo;

  {$endif}



  /// map the Delphi/FPC RTTI content

  TTypeInfo =

    {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}

    packed

    {$endif FPC_REQUIRES_PROPER_ALIGNMENT}

    record

    kind: TTypeKind;

    NameLen: byte;

    case TTypeKind of

    tkUnknown: (

      NameFirst: AnsiChar;

    );

    tkDynArray: (

      {$ifdef FPC}

      elSize: SizeUInt;

      elType2: PTypeInfoStored;

      varType: LongInt;

      elType: PTypeInfoStored;

      //DynUnitName: ShortStringBase;

      {$else}

      // storage byte count for this field

      elSize: Longint;

      // nil for unmanaged field

      elType: PTypeInfoStored;

      // OleAuto compatible type

      varType: Integer;

      // also unmanaged field

      elType2: PTypeInfoStored;

      {$endif}

    );

    tkArray: (

      {$ifdef FPC}

      // and $7FFFFFFF needed

      arraySize: SizeInt;

      // product of lengths of all dimensions

      elCount: SizeInt;

      {$else}

      arraySize: Integer;

      // product of lengths of all dimensions

      elCount: Integer;

      {$endif}

      arrayType: PTypeInfoStored;

      dimCount: Byte;

      dims: array[0..255 {DimCount-1}] of PTypeInfoStored;

    );

    {$ifdef FPC}

    tkRecord, tkObject:(

      recSize: longint;

      ManagedCount: longint;

    {$else}

    tkRecord: (

      recSize: cardinal;

      ManagedCount: integer;

    {$endif FPC}

      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}

    );

    tkEnumeration: (

      EnumType: TOrdType;

      {$ifdef FPC_ENUMHASINNER}

      inner:

      {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}

      packed

      {$endif}

      record

      {$endif}

      MinValue: longint;

      MaxValue: longint;

      EnumBaseType: PTypeInfoStored;

      {$ifdef FPC_ENUMHASINNER}

      end;

      {$endif}

      NameList: string[255];

    );

    tkInteger: (

      IntegerType: TOrdType;

    );

    tkSet: (

      SetType: TOrdType;

      SetBaseType: PTypeInfoStored;

    );

    tkFloat: (

      FloatType: TFloatType;

    );

    tkClass: (

      ClassType: PAnsiChar; // TClass;

      ParentInfo: PTypeInfoStored;

      PropCount: SmallInt;

      UnitNameLen: byte;

    );

  end;

  TPropInfo = packed record

    PropType: PTypeInfoStored;

    GetProc: PtrInt;

    SetProc: PtrInt;

    StoredProc: PtrInt;

    Index: Integer;

    Default: Longint;

    NameIndex: SmallInt;

    {$ifdef FPC}

    PropProcs : Byte;

    {$endif}

    NameLen: byte;

  end;

  PPropInfo = ^TPropInfo;



const

  /// codePage offset = string header size

  // - used to calc the beginning of memory allocation of a string

  STRRECSIZE = SizeOf(TStrRec);



function ToText(k: TTypeKind): PShortString; overload;

begin

  result := GetEnumName(TypeInfo(TTypeKind),ord(k));

end;



type

  TTypeInfoSaved = type TRawByteStringDynArray;



function TypeInfoFind(const rttitypes: TTypeInfoSaved;

  const typename: RawUTF8): pointer;

var i,len: integer;

begin

  len := length(typename);

  if len<>0 then begin

    for i := 0 to length(rttitypes)-1 do

      with PTypeInfo(rttitypes[i])^ do

      if (NameLen=len) and

         IdemPropNameUSameLen(@NameFirst,pointer(typename),len) then begin

        result := @kind;

        exit;

      end;

  end;

  result := nil;

end;



function TypeInfoFindIndex(const rttitypes: TTypeInfoSaved;

  info: pointer): integer;

var len: integer;

begin

  if info<>nil then begin

    len := PTypeInfo(info)^.NameLen+2; // compare Kind+Name

    for result := 0 to length(rttitypes)-1 do

      if CompareMem(pointer(rttitypes[result]),info,len) then

        exit;

  end;

  result := -1;

end;



var

  KnownTypeInfo: array of PTypeInfo;



{$ifdef HASDIRECTTYPEINFO}

type

  Deref = PTypeInfo;

{$else}

function Deref(Info: PTypeInfoStored): PTypeInfo;

{$ifdef HASINLINE} inline;

begin

  if Info=nil then

    result := pointer(Info) else

    result := Info^;

end;

{$else}

asm // Delphi is so bad at compiling above code...

    or eax,eax

    jz @z

    mov eax,[eax]

    ret

@z: db $f3 // rep ret

end;

{$endif HASINLINE}

{$endif HASDIRECTTYPEINFO}



/// add some TypeInfo() RTTI for TypeInfoSave/TypeInfoLoad function

// - warning: calling this after TypeInfoLoad() would trigger GPF

procedure TypeInfoSaveRegisterKnown(const Types: array of pointer);

var i,n: integer;

begin

  n := length(KnownTypeInfo);

  SetLength(KnownTypeInfo,n+length(Types));

  for i := 0 to high(Types) do

    KnownTypeInfo[n+i] := Types[i];

end;



function FindKnownTypeInfoIndex(typeinfo: pointer): integer;

  function Search(KindNameLen: word; Name: PUTF8Char; NameLen: integer): integer;

  begin // compare Kind+NameLen, then case-insensitive Name

    for result := 0 to length(KnownTypeInfo)-1 do

      with PTypeInfo(KnownTypeInfo[result])^ do

      if (PWord(kind)^=KindNameLen) and

         IdemPropNameUSameLen(@NameFirst,Name,NameLen) then

        exit;

    result := -1;

  end;

begin

  if typeinfo=nil then

    result := -1 else

    with PTypeInfo(typeinfo)^ do

      result := Search(PWord(@kind)^,@NameFirst,NameLen);

end;



/// binary external storage of low-level RTTI

// - add the RTTI to rttitypes[] in a stand-alone way (i.e. with no pointer)

// - return the index of the type in rttitypes[]

function TypeInfoSave(var rttitypes: TTypeInfoSaved;

  info: pointer): integer;

var k: TTypeKind;

    i,offs: integer;

    n: PAnsiChar;

    np: ^TPropInfo absolute n;

    rtti: PTypeInfo;

    tmp: TSynTempWriter;

  procedure wrtype(nested: PTypeInfoStored);

  var nfo: PTypeInfo;

      known: integer;

  begin

    nfo := Deref(nested);

    if nfo=nil then

      tmp.wrw(0) else

    if nfo=info then

      tmp.wrw(result+2) else begin

      known := FindKnownTypeInfoIndex(nfo);

      if known<0 then

        tmp.wrw(TypeInfoSave(rttitypes,nfo)+2) else begin

        tmp.wrw(1); // would be recognized by name

        with PTypeInfo(nfo)^ do

          tmp.wr(kind,NameLen+2); // match FindKnownTypeInfoIndex() 

      end;

    end;

  end;

begin

  result := TypeInfoFindIndex(rttitypes,info);

  if (result>=0) or (info=nil) then

    exit;

  result := length(rttitypes);

  tmp.Init; // no need of tmp.Done since maxsize=0 will use the stack

  rtti := info;

  k := rtti^.Kind;

  {$ifdef FPC} // storage binary layout is Delphi's

  i := ord(FPCTODELPHI[k]);

  tmp.wr(i,1);

  {$else}

  tmp.wr(k,sizeof(k));

  {$endif}

  tmp.wr(rtti^.NameLen,rtti^.NameLen+1);

  inc(PByte(rtti),rtti^.NameLen);

  {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

  rtti := align(rtti,sizeof(rtti));

  {$endif}

  with rtti^ do

  case k of

  tkChar, tkWChar, tkLString, tkWString, tkVariant, tkInt64

  {$ifdef UNICODE}, tkUString{$endif}:

    ; // no additional RTTI needed for those types

  tkDynArray: begin

    tmp.wrint(elSize);

    wrtype(elType);

    wrtype(elType2);

  end;

  tkEnumeration:

  {$ifdef FPC_ENUMHASINNER}with inner do{$endif} begin

    tmp.wr(EnumType,sizeof(EnumType));

    if MinValue<>0 then

      raise ESynException.CreateUTF8('TypeInfoSave MinValue=%',[MinValue]);

    tmp.wrw(MaxValue);

    wrtype(EnumBaseType);

    n := @NameList;

    for i := MinValue to MaxValue do

      inc(n,ord(n^)+1); // next short string (no align() needed on FPC)

    i := n-@NameList;

    tmp.wrw(i);

    tmp.wr(NameList,i);

  end;

  tkSet: begin

    tmp.wr(SetType,sizeof(SetType));

    wrtype(SetBaseType);

  end;

  tkInteger:

    tmp.wr(IntegerType,sizeof(IntegerType));

  tkFloat:

    tmp.wr(FloatType,sizeof(FloatType));

  tkClass: begin

    wrtype(ParentInfo);

    tmp.wrint(PropCount);

    tmp.wr(UnitNameLen,UnitNameLen+1);

    n := @UnitNameLen;

    inc(n,UnitNameLen+1);

    {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

    n := align(n,sizeof(n));

    {$endif}

    for i := 1 to PropCount do begin

      wrtype(np^.PropType);

      offs := np^.GetProc;

      {$ifndef FPC}

      if offs and {$ifdef CPU64}$ff00000000000000{$else}$ff000000{$endif}<>0 then

        raise ESynException.CreateUTF8('TypeInfoSave no getter for %',

          [PShortString(np^.NameLen)^]);

      {$endif}

      tmp.wrint(offs);

      tmp.wrb(np^.StoredProc);

      tmp.wrint(np^.Index);

      tmp.wrint(np^.Default);

      tmp.wrw(np^.NameIndex);

      tmp.wr(np^.NameLen,np^.NameLen+1);

      n := PAnsiChar(@np^.NameLen)+np^.NameLen+1;

      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

      n := align(n,sizeof(n));

      {$endif}

    end;

  end;

  else

    raise ESynException.CreateUTF8('TypeInfoSave(%) unsupported',[ToText(k)^]);

  end;

  SetLength(rttitypes,result+1);

  rttitypes[result] := tmp.AsBinary;

end;



procedure TypeInfoLoad(var rttitypes: TTypeInfoSaved);

var rtti: PTypeInfo;

    tmp: TSynTempWriter;

    i,t,j,pcount: integer;

    offs: PtrUInt;

    stored: boolean; 

    k: TTypeKind;

    n: PAnsiChar;

    types: array of array of packed record

      offs: word;

      typindex: word;

    end;

    p1: pointer;

  function nint: integer;

  begin

    result := PInteger(n)^;

    inc(n,4);

  end;

  function nw: integer;

  begin

    result := PWord(n)^;

    inc(n,2);

  end;

  function nb: integer;

  begin

    result := PByte(n)^;

    inc(n);

  end;

  procedure wrss;

  var len: integer;

  begin

    len := PByte(n)^+1;

    tmp.wr(n^,len); // copy whole shortstring at once

    inc(n,len);

    {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

    n := align(n,sizeof(n));

    {$endif}

  end;

  function wrtype: pointer;

  var index,off,ti: integer;

  begin

    result := tmp.pos;

    index := nw;

    if index=1 then begin

      ti := FindKnownTypeInfoIndex(n);

      if ti<0 then

        raise ESynException.CreateUTF8('TypeInfoLoad index=1 %?',

          [PShortString(@PTypeInfo(n)^.NameLen)^]);

      inc(n,PTypeInfo(n)^.NameLen+2);

      {$ifdef FPC} // follow PTypeInfoStored pattern

      tmp.wrptr(pointer(KnownTypeInfo[ti]));

      {$else}

      // warning: any future TypeInfoSaveRegisterKnown() would trigger GPF

      tmp.wrptr(@pointer(KnownTypeInfo[ti]));

      {$endif}

      exit;

    end;

    off := tmp.Position;

    tmp.wrptr(nil);

    if index=0 then

      exit;

    SetLength(types[i],t+1);

    with types[i,t] do begin

      offs := off;

      typindex := index-2;

    end;

    inc(t);

  end;

begin

  SetLength(types,Length(rttitypes));

  for i := 0 to Length(rttitypes)-1 do begin

    t := 0;

    tmp.Init;

    rtti := pointer(rttitypes[i]);

    {$ifdef FPC}

    k := DELPHITOFPC[TDelphiTypeKind(rtti^.Kind)];

    if (k=tkEnumeration) and

       IdemPropName(PShortString(rtti^.NameLen)^,'boolean') then

      k := tkBool;

    {$else}

    k := rtti^.Kind;

    {$endif}

    tmp.wr(k,sizeof(k));

    n := @rtti^.NameLen; // n^ points to variable buffer -> use nb/nw/nint

    wrss; // copy Name

    case k of

    tkChar, tkWChar, tkLString, tkWString, tkVariant, tkInt64

    {$ifdef UNICODE}, tkUString{$endif}

    {$ifdef FPC}, tkBool{$endif}:

      ; // no additional RTTI needed for those types

    tkDynArray: begin // elSize,elType,elType2

      {$ifdef FPC}

      tmp.wrptrint(nint);

      p1 := wrtype;

      tmp.wrint(0);

      Exchg(p1,wrtype,sizeof(pointer)); // invert elType <-> elType2

      {$else}

      tmp.wrint(nint);

      wrtype;

      tmp.wrint(0);

      wrtype;

      {$endif}

    end;

    tkEnumeration: begin

      tmp.wrb(nb);

      tmp.wrint(0); // MinValue

      tmp.wrint(nint);

      wrtype;

      j := nw;

      tmp.wr(n^,j); // NameList

    end;

    tkInteger, tkFloat:

      tmp.wrb(nb);

    tkSet: begin

      tmp.wrb(nb);

      wrtype;

    end;

    tkClass: begin

      p1 := tmp.wrfillchar(sizeof(pointer),0);

      wrtype;

      pcount := nw;

      tmp.wrw(pcount);

      wrss; // copy UnitName

      for j := 1 to pcount do begin

        wrtype;             // PropType

        offs := nint;       // GetProc=SetProc=fieldaddr

        {$ifndef FPC}

        offs := offs or {$ifdef CPU64}$ff00000000000000{$else}$ff000000{$endif};

        {$endif}

        tmp.wrptrint(offs);

        tmp.wrptrint(offs);

        stored := nb<>0;

        if stored then

          tmp.wrptrint(-1) else

          tmp.wrptrint(0);

        tmp.wrint(nint);    // Index

        tmp.wrint(nint);    // Default

        tmp.wrw(nw);        // NameIndex

        {$ifdef FPC} // PropProcs: GetProc=SetProc=ptField

        if stored then

          tmp.wrb(ptconst shl 4) else

          tmp.wrb(0);

        {$endif}

        wrss; // copy Name

      end;

      // FIX: compute TClass at p1^

      PPointer(p1)^ := nil;

    end;

    else

      raise ESynException.CreateUTF8('TypeInfoLoad(%) unsupported',[ToText(k)^]);

    end;

    rttitypes[i] := tmp.AsBinary; // replace with true RTTI

  end;

  // fix all internal pointers

  for i := 0 to Length(rttitypes)-1 do begin

    n := pointer(rttitypes[i]);

    for t := 0 to length(types[i])-1 do

    with types[i,t] do

      {$ifdef FPC} // follow PTypeInfoStored pattern

      PPointer(n+offs)^ := pointer(rttitypes[typindex]);

      {$else}

      PPointer(n+offs)^ := @pointer(rttitypes[typindex]);

      {$endif}

  end;

end;



procedure SetRawUTF8(var Dest: RawUTF8; text: pointer; len: integer);

{$ifdef FPC}inline;

begin

  if (len>128) or (len=0) or (text<>pointer(Dest)) then

    SetString(Dest,PAnsiChar(text),len) else

    SetLength(Dest,len);

end;

{$else}

{$ifdef PUREPASCAL}

var P: PStrRec;

begin

  if (len>128) or (len=0) or (PtrInt(Dest)=0) or     // Dest=''

    (PStrRec(PtrInt(Dest)-STRRECSIZE)^.refCnt<>1) then

    SetString(Dest,PAnsiChar(text),len) else begin

    if PStrRec(Pointer(PtrInt(Dest)-STRRECSIZE))^.length<>len then begin

      P := Pointer(PtrInt(Dest)-STRRECSIZE);

      ReallocMem(P,len+(STRRECSIZE+1));

      P^.length := len;

      pointer(Dest) := pointer(PAnsiChar(P)+STRRECSIZE);

      PByteArray(Dest)[len] := 0;

    end;

    MoveFast(pointer(text)^,pointer(Dest)^,len);

  end;

end;

{$else}

asm // eax=@Dest text=edx len=ecx

    cmp ecx,128 // avoid huge move() in ReallocMem()

{$ifdef UNICODE}

    ja @3

{$else}

    ja System.@LStrFromPCharLen

{$endif}

    test ecx,ecx // len=0

{$ifdef UNICODE}

    jz @3

{$else}

    jz System.@LStrFromPCharLen

{$endif}

    push ebx

    mov ebx,[eax]

    test ebx,ebx

    jnz @2

@0: pop ebx

{$ifdef UNICODE}

@3: push CP_UTF8 // UTF-8 code page for Delphi 2009+

    call System.@LStrFromPCharLen // we need a call, not a jmp here

    rep ret

{$else}

    jmp System.@LStrFromPCharLen

{$endif}

@2: cmp dword ptr [ebx-8],1

    jne @0

    cmp dword ptr [ebx-4],ecx

    je @1

    sub ebx,STRRECSIZE

    push edx

    push eax

    push ecx

    push ebx

    mov eax,esp // ReallocMem() over ebx pointer on stack

    lea edx,ecx+STRRECSIZE+1

    call System.@ReallocMem

    pop ebx

    pop ecx

    add ebx,STRRECSIZE

    pop eax

    pop edx

    mov [eax],ebx

    mov dword ptr [ebx-4],ecx

    mov byte ptr [ebx+ecx],0

@1: mov eax,edx

    mov edx,ebx

    call dword ptr [MoveFast]

    pop ebx

end;

{$endif}

{$endif}



function UniqueRawUTF8(var UTF8: RawUTF8): pointer;

begin

  {$ifdef FPC}

  UniqueString(UTF8); // @UTF8[1] won't call UniqueString() under FPC :(

  {$endif}

  result := @UTF8[1];

end;



{$ifdef FPC}

function TDynArrayRec.GetLength: sizeint;

begin

  result := high+1;

end;



procedure TDynArrayRec.SetLength(len: sizeint);

begin

  high := len-1;

end;

{$endif}



function DynArrayLength(Value: Pointer): integer;

  {$ifdef HASINLINE}inline;{$endif}

begin

  if Value=nil then

    result := PtrInt(Value) else begin

    {$ifdef FPC}

    result := PDynArrayRec(PtrUInt(Value)-SizeOf(TDynArrayRec))^.length;

    {$else}

    result := PInteger(PtrUInt(Value)-sizeof(PtrInt))^;

    {$endif}

  end;

end;



function GetTypeInfo(aTypeInfo: pointer; aExpectedKind: TTypeKind): PTypeInfo; overload;

{$ifdef HASINLINE} inline;

begin

  if (aTypeInfo<>nil) and (PTypeKind(aTypeInfo)^=aExpectedKind) then begin

    {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

    result := GetFPCAlignPtr(aTypeInfo);

    {$else}

    result := aTypeInfo;

    inc(PtrUInt(result),result^.NameLen);

    {$endif}

  end else

    result := nil;

end;

{$else}

asm

    test eax,eax

    jz @n

    cmp dl,[eax]

    movzx ecx,byte ptr [eax+TTypeInfo.NameLen]

    jnz @n

    add eax,ecx

    ret

@n: xor eax,eax

end;

{$endif}



function GetTypeInfo(aTypeInfo: pointer; const aExpectedKind: TTypeKinds): PTypeInfo; overload;

{$ifdef HASINLINE} inline;

begin

  result := aTypeInfo;

  if (result<>nil) and (result^.Kind in aExpectedKind) then

    {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

    result := GetFPCAlignPtr(result)

    {$else}

    inc(PtrUInt(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}



function DynArrayTypeInfoToRecordInfo(aDynArrayTypeInfo: pointer;

  aDataSize: PInteger=nil): pointer;

var info: PTypeInfo;

begin

  result := nil;

  info := GetTypeInfo(aDynArrayTypeInfo,tkDynArray);

  if info=nil then

    exit;

  if info^.elType<>nil then

    result := Deref(info^.elType);

  if aDataSize<>nil then

    aDataSize^ := info^.elSize {$ifdef FPC}and $7FFFFFFF{$endif};

end;



procedure TypeInfoToName(aTypeInfo: pointer; var result: RawUTF8;

  const default: RawUTF8='');

begin

  if aTypeInfo<>nil then

    SetRawUTF8(result,PAnsiChar(@PTypeInfo(aTypeInfo)^.NameLen)+1,

      PTypeInfo(aTypeInfo)^.NameLen) else

    result := default;

end;



procedure TypeInfoToQualifiedName(aTypeInfo: pointer; var result: RawUTF8;

  const default: RawUTF8='');

var unitname: RawUTF8;

begin

  if aTypeInfo<>nil then begin

    SetRawUTF8(result,PAnsiChar(@PTypeInfo(aTypeInfo)^.NameLen)+1,

      PTypeInfo(aTypeInfo)^.NameLen);

    if PTypeInfo(aTypeInfo)^.Kind=tkClass then begin

      with GetTypeInfo(aTypeInfo,PTypeKind(aTypeInfo)^)^ do

        SetRawUTF8(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,tkRecordTypeOrSet);

  if info=nil then

    result := 0 else

    result := info^.recSize;

end;



function GetEnumInfo(aTypeInfo: pointer; out MaxValue: Integer;

  out Names: PShortString): boolean;

{$ifdef HASINLINE} inline;

var info: PTypeInfo;

begin

  info := GetTypeInfo(aTypeInfo,tkEnumeration);

  if info<>nil then begin

    {$ifdef FPC}

    if info^.{$ifdef FPC_ENUMHASINNER}inner.{$endif}EnumBaseType<>nil then

    {$endif}

      info := GetTypeInfo(Deref(info^.{$ifdef FPC_ENUMHASINNER}inner.{$endif}EnumBaseType),tkEnumeration);

    MaxValue := info^.{$ifdef FPC_ENUMHASINNER}inner.{$endif}MaxValue;

    Names := @info.NameList;

    result := true;

  end else

    result := false;

end;

{$else}

asm // eax=aTypeInfo edx=@MaxValue ecx=@Names

    test eax,eax

    jz @n

    cmp byte ptr [eax],tkEnumeration

    jnz @n

    push ecx

    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

    pop ecx

    lea eax,[eax+TTypeInfo.NameList]

    mov [ecx],eax

    mov al,1

    ret

@n: xor eax,eax

end;

{$endif}



function GetSetInfo(aTypeInfo: pointer; out MaxValue: Integer;

  out Names: PShortString): boolean;

var info: PTypeInfo;

begin

  info := GetTypeInfo(aTypeInfo,tkSet);

  if info<>nil then

    {$ifdef FPC}

    if info^.SetBaseType=nil then

      result := GetEnumInfo(aTypeInfo,MaxValue,Names) else

    {$endif}

      result := GetEnumInfo(Deref(info^.SetBaseType),MaxValue,Names) else

    result := false;

end;



function GetEnumName(aTypeInfo: pointer; aIndex: integer): PShortString;

const NULL_SHORTSTRING: string[1] = '';

{$ifdef HASINLINE}

var MaxValue: integer;

begin

  if GetEnumInfo(aTypeInfo,MaxValue,result) and

     (cardinal(aIndex)<=cardinal(MaxValue)) then

    while aIndex>0 do begin

      dec(aIndex);

      inc(PByte(result),ord(result^[0])+1); // next short string

    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 pipelined by-four scanning

    jz     @1

@4: dec    edx

    movzx  ecx,byte ptr [eax]

    lea    eax,[eax+ecx+1]

    movzx  ecx,byte ptr [eax]

    lea    eax,[eax+ecx+1]

    movzx  ecx,byte ptr [eax]

    lea    eax,[eax+ecx+1]

    movzx  ecx,byte ptr [eax]

    lea    eax,[eax+ecx+1]

    jnz    @4

    pop    edx

    and    edx,3

    jnz    @s

    ret

@1: pop    edx

@s: movzx  ecx,byte ptr [eax]

    dec    edx

    lea    eax,[eax+ecx+1] // next short string

    jnz    @s

    ret

@z: rep ret

@0: lea    eax,NULL_SHORTSTRING

end;

{$endif}



function FindShortStringListExact(List: PShortString; MaxValue: integer;

  aValue: PUTF8Char; aValueLen: integer): integer;

var PLen: integer;

begin

  for result := 0 to MaxValue do begin

    PLen := ord(List^[0]);

    if (PLen=aValuelen) and IdemPropNameUSameLen(@List^[1],aValue,aValueLen) then

      exit else

      inc(PByte(List),PLen+1); // next short string

  end;

  result := -1;

end;



function FindShortStringListTrimLowerCase(List: PShortString; MaxValue: integer;

  aValue: PUTF8Char; aValueLen: integer): integer;

var PLen: integer;

begin

  for result := 0 to MaxValue do begin

    PLen := ord(List^[0]);

    inc(PUTF8Char(List));

    repeat

      if not(PUTF8Char(List)^ in ['a'..'z']) then

        break;

      inc(PUTF8Char(List));

      dec(PLen);

    until PLen=0;

    if (PLen=aValueLen) and IdemPropNameUSameLen(aValue,PUTF8Char(List),PLen) then

      exit else

      inc(PUTF8Char(List),PLen);

  end;

  result := -1;

end;



function GetEnumNameValue(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: integer;

  AlsoTrimLowerCase: boolean): Integer;

var List: PShortString;

    MaxValue: integer;

begin

  if GetEnumInfo(aTypeInfo,MaxValue,List) then begin

    result := FindShortStringListExact(List,MaxValue,aValue,aValueLen);

    if (result<0) and AlsoTrimLowerCase then

      result := FindShortStringListTrimLowerCase(List,MaxValue,aValue,aValueLen);

  end else

    result := -1;

end;



function GetEnumNameValueTrimmed(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: integer): integer;

var List: PShortString;

    MaxValue: integer;

begin

  if GetEnumInfo(aTypeInfo,MaxValue,List) then

    result := FindShortStringListTrimLowerCase(List,MaxValue,aValue,aValueLen) else

    result := -1;

end;



function GetEnumNameValue(aTypeInfo: pointer; const aValue: RawUTF8;

  AlsoTrimLowerCase: boolean=false): Integer;

begin

  result := GetEnumNameValue(aTypeInfo, pointer(aValue), length(aValue),

    AlsoTrimLowerCase);

end;



function GetSetNameValue(aTypeInfo: pointer; var P: PUTF8Char;

  out EndOfObject: AnsiChar): cardinal;

var Names: PShortString;

    Text: PUTF8Char;

    wasString: boolean;

    MaxValue, TextLen, i: integer;

begin

  result := 0;

  if (P<>nil) and GetSetInfo(aTypeInfo,MaxValue,Names) then begin

    P := GotoNextNotSpace(P);

    if P^='[' then begin

      P := GotoNextNotSpace(P+1);

      if P^=']' then begin

        EndOfObject := ']';

        P := GotoNextNotSpace(P+1);

      end else

      repeat

        Text := GetJSONField(P,P,@wasString,@EndOfObject);

        if (Text=nil) or not wasString then begin

          P := nil;

          break;

        end;

        if Text^='*' then begin

          if MaxValue<32 then

            result := ALLBITS_CARDINAL[MaxValue+1] else

            result := cardinal(-1);

          exit;

        end;

        TextLen := StrLen(Text);

        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

          SetBit(result,i);

        // unknown enum names (i=-1) would just be ignored

      until EndOfObject=']';

    end else

      result := GetCardinal(GetJSONField(P,P,nil,@EndOfObject));

  end;

end;





{ note: those low-level VariantTo*() functions are expected to be there

        even if NOVARIANTS conditional is defined (used e.g. by SynDB.TQuery) }



function VariantToInteger(const V: Variant; var Value: integer): boolean;

var tmp: TVarData;

begin

  with TVarData(V) do

  case VType of

  varNull,

  varEmpty:    Value := 0;

  varBoolean:  Value := ord(VBoolean);

  varSmallint: Value := VSmallInt;

  {$ifndef DELPHI5OROLDER}

  varShortInt: Value := VShortInt;

  varWord:     Value := VWord;

  varLongWord:

    if (VLongWord>=cardinal(Low(integer))) and (VLongWord<=cardinal(High(integer))) then

      Value := VLongWord else begin

      result := false;

      exit;

    end;

  {$endif}

  varByte:     Value := VByte;

  varInteger:  Value := VInteger;

  varWord64:

    if (VInt64>=0) and (VInt64<=High(integer)) then

      Value := VInt64 else begin

      result := False;

      exit;

    end;

  varInt64:

    if (VInt64>=Low(integer)) and (VInt64<=High(integer)) then

      Value := VInt64 else begin

      result := False;

      exit;

    end;

  else

    if SetVariantUnRefSimpleValue(V,tmp) then begin

      result := VariantToInteger(variant(tmp),Value);

      exit;

    end else begin

      result := false;

      exit;

    end;

  end;

  result := true;

end;



function VariantToDouble(const V: Variant; var Value: double): boolean;

var tmp: TVarData;

begin

  with TVarData(V) do

  if VType=varVariant or varByRef then

    result := VariantToDouble(PVariant(VPointer)^,Value) else

  if VariantToInt64(V,tmp.VInt64) then begin // also handle varEmpty,varNull

    Value := tmp.VInt64;

    result := true;

  end else

  case VType of

  varDouble,varDate: begin

    Value := VDouble;

    result := true;

  end;

  varSingle: begin

    Value := VSingle;

    result := true;

  end;

  varCurrency: begin

    Value := VCurrency;

    result := true;

  end else

    if SetVariantUnRefSimpleValue(V,tmp) then

      result := VariantToDouble(variant(tmp),Value) else

      result := false;

  end;

end;



function VariantToCurrency(const V: Variant; var Value: currency): boolean;

var tmp: TVarData;

begin

  with TVarData(V) do

  if VType=varVariant or varByRef then

    result := VariantToCurrency(PVariant(VPointer)^,Value) else

  if VariantToInt64(V,tmp.VInt64) then begin

    Value := tmp.VInt64;

    result := true;

  end else

  case VType of

  varDouble,varDate: begin

    Value := VDouble;

    result := true;

  end;

  varSingle: begin

    Value := VSingle;

    result := true;

  end;

  varCurrency: begin

    Value := VCurrency;

    result := true;

  end else

    if SetVariantUnRefSimpleValue(V,tmp) then

      result := VariantToCurrency(variant(tmp),Value) else

      result := false;

  end;

end;



function VariantToBoolean(const V: Variant; var Value: Boolean): boolean;

var tmp: TVarData;

begin

  if TVarData(V).VType=varBoolean then

    Value := TVarData(V).VBoolean 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;

  result := true;

end;



function VariantToInt64(const V: Variant; var Value: Int64): boolean;

var tmp: TVarData;

begin

  with TVarData(V) do

  case VType of

  varNull,

  varEmpty:    Value := 0;

  varBoolean:  Value := ord(VBoolean);

  varSmallint: Value := VSmallInt;

  {$ifndef DELPHI5OROLDER}

  varShortInt: Value := VShortInt;

  varWord:     Value := VWord;

  varLongWord: Value := VLongWord;

  {$endif}

  varByte:     Value := VByte;

  varInteger:  Value := VInteger;

  varWord64,

  varInt64:    Value := VInt64;

  else

    if SetVariantUnRefSimpleValue(V,tmp) then begin

      result := VariantToInt64(variant(tmp),Value);

      exit;

    end else begin

      result := false;

      exit;

    end;

  end;

  result := true;

end;



function VariantToInt64Def(const V: Variant; DefaultValue: Int64): Int64;

begin

  if not VariantToInt64(V,result) then

    result := DefaultValue;

end;



function VariantToIntegerDef(const V: Variant; DefaultValue: integer): integer;

begin

  if not VariantToInteger(V,result) then

    result := DefaultValue;

end;



{$ifndef NOVARIANTS}



function VariantToDateTime(const V: Variant; var Value: TDateTime): boolean;

var tmp: RawUTF8;

    vd: TVarData;

begin

  with TVarData(V) do

  if VType=varVariant or varByRef then

    result := VariantToDateTime(PVariant(VPointer)^,Value) else

  case VType of

  varDouble,varDate: begin

    Value := VDouble;

    result := true;

  end;

  varSingle: begin

    Value := VSingle;

    result := true;

  end;

  varCurrency: begin

    Value := VCurrency;

    result := true;

  end else

    if SetVariantUnRefSimpleValue(V,vd) then

      result := VariantToDateTime(variant(vd),Value) else begin

      VariantToUTF8(V,tmp);

      Iso8601ToDateTimePUTF8CharVar(pointer(tmp),length(tmp),Value);

      result := Value<>0;

    end;

  end;

end;



procedure VariantToInlineValue(const V: Variant; var result: RawUTF8);

var wasString: boolean;

begin

  VariantToUTF8(V,result,wasString);

  if wasString then

    result := QuotedStr(pointer(result),'"');

end;



function VariantToVariantUTF8(const V: Variant): variant;

var tmp: RawUTF8;

    wasString: boolean;

begin

  VariantToUTF8(V,tmp,wasString);

  if wasString then

    result := V else

    RawUTF8ToVariant(tmp,result);

end;



procedure VariantToUTF8(const V: Variant; var result: RawUTF8;

  var wasString: boolean); overload;

var tmp: TVarData;

begin

  wasString := false;

  with TVarData(V) do

  case VType of

  varEmpty,

  varNull:

    result := 'null';

  varSmallint:

    Int32ToUTF8(VSmallInt,result);

  {$ifndef DELPHI5OROLDER}

  varShortInt:

    Int32ToUTF8(VShortInt,result);

  varWord:

    UInt32ToUTF8(VWord,result);

  varLongWord:

    UInt32ToUTF8(VLongWord,result);

  {$endif}

  varByte,

  varBoolean:

    UInt32ToUTF8(VByte,result);

  varInteger:

    Int32ToUTF8(VInteger,result);

  varInt64,

  varWord64:

    Int64ToUTF8(VInt64,result);

  varSingle:

    ExtendedToStr(VSingle,SINGLE_PRECISION,result);

  varDouble:

    ExtendedToStr(VDouble,DOUBLE_PRECISION,result);

  varCurrency:

    Curr64ToStr(VInt64,result);

  varDate: begin

    wasString := true;

    DateTimeToIso8601TextVar(VDate,'T',result);

  end;

  varString: begin

    wasString := true;

  {$ifdef HASCODEPAGE}

    AnyAnsiToUTF8(RawByteString(VString),result);

  {$else}

    result := RawUTF8(VString);

  {$endif}

  end;

  {$ifdef HASVARUSTRING}

  varUString: begin

    wasString := true;

    RawUnicodeToUtf8(VAny,length(UnicodeString(VAny)),result);

  end;

  {$endif}

  varOleStr: begin

    wasString := true;

    RawUnicodeToUtf8(VAny,length(WideString(VAny)),result);

  end;

  else

  if SetVariantUnRefSimpleValue(V,tmp) then

    VariantToUTF8(Variant(tmp),result,wasString) else

  if VType=varVariant or varByRef then // complex varByRef

    VariantToUTF8(PVariant(VPointer)^,result,wasString) else

  if VType=varByRef or varString then begin

    wasString := true;

    {$ifdef HASCODEPAGE}

    AnyAnsiToUTF8(PRawByteString(VString)^,result);

    {$else}

    result := PRawUTF8(VString)^;

    {$endif}

  end else

  if VType=varByRef or varOleStr then begin

    wasString := true;

    RawUnicodeToUtf8(pointer(PWideString(VAny)^),length(PWideString(VAny)^),result);

  end else

  {$ifdef HASVARUSTRING}

  if VType=varByRef or varUString then begin

    wasString := true;

    RawUnicodeToUtf8(pointer(PUnicodeString(VAny)^),length(PUnicodeString(VAny)^),result);

  end else

  {$endif}

    VariantSaveJSON(V,twJSONEscape,result); // will handle also custom types

  end;

end;



function VariantToUTF8(const V: Variant): RawUTF8;

var wasString: boolean;

begin

  VariantToUTF8(V,result,wasString);

end;



function ToUTF8(const V: Variant): RawUTF8; overload;

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): boolean;

  function Complex(const V: Variant; const Str: RawUTF8): boolean;

  var wasString: boolean;

      tmp: RawUTF8;

  begin

    VariantToUTF8(V,tmp,wasString);

    result := (tmp=Str);

  end;

begin

  with TVarData(V) do

    case VType of

    varEmpty,varNull:

      result := false;

    varString:

      result := RawUTF8(VAny)=Str;

    else

      result := Complex(V,Str);

  end;

end;



function VariantToString(const V: Variant): string;

var wasString: boolean;

    tmp: RawUTF8;

begin

  with TVarData(V) do

    case VType of

    varEmpty,varNull:

      result := ''; // default VariantToUTF8(null)='null'

    {$ifdef UNICODE} // not HASVARUSTRING: here we handle string=UnicodeString

    varUString:

      result := UnicodeString(VAny);

    else

    if VType=varByRef or varUString then

      result := PUnicodeString(VAny)^

    {$endif}

    else begin

      VariantToUTF8(V,tmp,wasString);

      if tmp='' then

        result := '' else

        UTF8DecodeToString(pointer(tmp),length(tmp),result);

    end;

    end;

end;



procedure VariantToSQLVar(const Input: variant; var temp: RawByteString;

  var Output: TSQLVar);

var wasString: boolean;

begin

  with TVarData(Input) do

  if VType=varVariant or varByRef then

    VariantToSQLVar(PVariant(VPointer)^,temp,Output) else

  case VType of

  varEmpty, varNull:

    Output.VType := ftNull;

  varCurrency: begin

    Output.VType := ftCurrency;

    Output.VInt64 := VInt64;

  end;

  varString: begin // assume RawUTF8

    Output.VType := ftUTF8;

    Output.VText := VPointer;

  end;

  varInteger: begin

    Output.VType := ftInt64;

    Output.VInt64 := VInteger;

  end;

  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;

  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;



procedure VariantDynArrayClear(var Value: TVariantDynArray);

var p: PDynArrayRec;

    V: PVarData;

    i: integer;

    handler: TCustomVariantType;

begin

  if pointer(Value)=nil then

    exit;

  p := pointer(PtrUInt(Value)-Sizeof(TDynArrayRec)); // p^ = start of heap object

  V := pointer(Value);

  pointer(Value) := nil;

  if p^.refCnt>1 then begin

    InterlockedDecrement(PInteger(@p^.refCnt)^); // FPC has refCnt: PtrInt

    exit;

  end;

  handler := nil;

  for i := 1 to p^.length do begin

    case V^.VType of

    varEmpty..varDate,varError,varBoolean,varShortInt..varWord64: ;

    varString: RawUTF8(V^.VAny) := '';

    varOleStr: WideString(V^.VAny) := '';

    {$ifdef HASVARUSTRING}

    varUString: UnicodeString(V^.VAny) := '';

    {$endif}

    else

    if V^.VType=word(DocVariantVType) then

      DocVariantType.Clear(V^) else

    if V^.VType=varVariant or varByRef then

      VarClear(PVariant(V^.VPointer)^) else

    if handler=nil then

      if (V^.VType and varByRef=0) and

         FindCustomVariantType(V^.VType,handler) then

        handler.Clear(V^) else 

        VarClear(variant(V^)) else

      if V^.VType=handler.VarType then

        handler.Clear(V^) else

        VarClear(variant(V^));

    end;

    inc(V);

  end;

  FreeMem(p);

end;



{$endif NOVARIANTS}





{$ifdef UNICODE}

// this Pos() is seldom used, it was decided to only define it under

// Delphi 2009+ (which expect such a RawUTF8 specific overloaded version)



function Pos(const substr, str: RawUTF8): Integer; overload;

begin

  Result := PosEx(substr, str, 1);

end;



function IntToString(Value: integer): string;

var tmp: array[0..15] of AnsiChar;

    P: PAnsiChar;

begin

  P := StrInt32(@tmp[15],Value);

  Ansi7ToString(PWinAnsiChar(P),@tmp[15]-P,result);

end;



function IntToString(Value: cardinal): string;

var tmp: array[0..15] of AnsiChar;

    P: PAnsiChar;

begin

  P := StrUInt32(@tmp[15],Value);

  Ansi7ToString(PWinAnsiChar(P),@tmp[15]-P,result);

end;



function IntToString(Value: Int64): string;

var tmp: array[0..31] of AnsiChar;

    P: PAnsiChar;

begin

  P := StrInt64(@tmp[31],Value);

  Ansi7ToString(PWinAnsiChar(P),@tmp[31]-P,result);

end;



function DoubleToString(Value: Double): string;

var tmp: ShortString;

begin

  if Value=0 then

    result := '0' else

    Ansi7ToString(PWinAnsiChar(@tmp[1]),

      ExtendedToString(tmp,Value,DOUBLE_PRECISION),result);

end;



function Curr64ToString(Value: Int64): string;

var tmp: array[0..31] of AnsiChar;

begin

  Ansi7ToString(tmp,Curr64ToPChar(Value,tmp),result);

end;



{$else UNICODE}



function IntToString(Value: integer): string;

{$ifdef PUREPASCAL}

var tmp: array[0..15] of AnsiChar;

    P: PAnsiChar;

begin

  P := StrInt32(@tmp[15],Value);

  SetString(result,P,@tmp[15]-P);

end;

{$else}

asm

  jmp Int32ToUTF8

end;

{$endif}



function IntToString(Value: cardinal): string;

var tmp: array[0..15] of AnsiChar;

    P: PAnsiChar;

begin

  P := StrUInt32(@tmp[15],Value);

  SetString(result,P,@tmp[15]-P);

end;



function IntToString(Value: Int64): string;

var tmp: array[0..31] of AnsiChar;

    P: PAnsiChar;

begin

  P := StrInt64(@tmp[31],Value);

  SetString(result,P,@tmp[31]-P);

end;



function DoubleToString(Value: Double): string;

var tmp: ShortString;

begin

  if Value=0 then

    result := '0' else

    SetString(result,PAnsiChar(@tmp[1]),ExtendedToString(tmp,Value,DOUBLE_PRECISION));

end;



function Curr64ToString(Value: Int64): string;

begin

  result := Curr64ToStr(Value);

end;



{$endif UNICODE}



{$ifdef PUREPASCAL}

function bswap32(a: cardinal): cardinal; {$ifdef HASINLINE}inline;{$endif}

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;

{$else}

{$ifdef CPUX64}

function bswap32(a: cardinal): cardinal;

{$ifdef FPC}nostackframe; assembler;

asm

{$else}

asm

  .NOFRAME // ecx=a (Linux: edi)

{$endif FPC}

  {$ifdef win64}

  mov eax,ecx

  {$else}

  mov eax,edi

  {$endif win64} 

  bswap eax

end;

{$endif CPUX64}

{$ifdef CPUX86}

function bswap32(a: cardinal): cardinal;

asm

  bswap eax

end;

{$endif CPUX86}

{$endif PUREPASCAL}



{$ifndef PUREPASCAL} { these functions are implemented in asm }

{$ifndef LVCL}       { don't define these functions twice }

{$ifndef FPC}        { these asm function use some low-level system.pas calls }



{$define DEFINED_INT32TOUTF8}



function Int32ToUTF8(Value : integer): 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 Digits 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=Digits (Including Sign Character)}

  mov    ecx,[edx]              {result}

  test   ecx,ecx

  je     @@NewStr               {Create New string for result}

  cmp    dword ptr [ecx-8], 1

  jne    @@ChangeStr            {Reference Count <> 1}

  cmp    esi,[ecx-4]

  je     @@LengthOk             {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    @@LengthOk

@@ChangeStr:

  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)}

@@LengthOk:

  mov    byte ptr [ecx],'-'      {Store '-' Character (May be Overwritten)}

  add    esi,ebx                 {Digits (Excluding Sign Character)}

  sub    ecx,ebx                 {Destination of 1st Digit}

  sub    esi,2                   {Digits (Excluding Sign Character) - 2}

  jle    @@FinalDigits           {1 or 2 Digit Value}

  cmp    esi,8                   {10 Digit Value?}

  jne    @@SetResult             {Not a 10 Digit Value}

  sub    eax,2000000000          {Digit 10 must be either '1' or '2'}

  mov    dl,'2'

  jnc    @@SetDigit10            {Digit 10 = '2'}

  mov    dl,'1'                  {Digit 10 = '1'}

  add    eax,1000000000

@@SetDigit10:

  mov    [ecx],dl                {Save Digit 10}

  mov    esi,7                   {9 Digits Remaining}

  add    ecx,1                   {Destination of 2nd Digit}

@@SetResult:

  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 Digits Remaining}

@@FinalDigits:

  pop    esi

  pop    edi

  pop    ebx

  jnz    @@LastDigit

  movzx  eax,word ptr [TwoDigitLookup+eax*2]

  mov    [ecx],ax                {Save Final 2 Digits}

  ret

@@LastDigit:

  or     al,'0'                  {Ascii Adjustment}

  mov    [ecx],al                {Save Final Digit}

end;



function Int64ToUTF8(Value: Int64): RawUtf8;

// from IntToStr64_JOH_IA32_6_b, adapted for Delphi 2009+

asm

  push   ebx

  mov    ecx, [ebp+8]            {Low Integer of Value}

  mov    edx, [ebp+12]           {High Integer of Value}

  xor    ebp, ebp                {Clear Sign Flag (EBP Already Pushed)}

  mov    ebx, ecx                {Low Integer of Value}

  test   edx, edx

  jnl    @@AbsValue

  mov    ebp, 1                  {EBP = 1 for -ve Value or 0 for +ve Value}

  neg    ecx

  adc    edx, 0

  neg    edx

@@AbsValue:                      {EDX:ECX = Abs(Value)}

  jnz    @@Large

  test   ecx, ecx

  js     @@Large

  mov    edx, eax                {@Result}

  mov    eax, ebx                {Low Integer of Value}

  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

@@Test15:                        {Test for 15 or More Digits}

  cmp    edx, $00005af3          {100000000000000 div $100000000}

  jne    @@Check15

  cmp    ecx, $107a4000          {100000000000000 mod $100000000}

@@Check15:

  jb     @@Test13

@@Test17:                        {Test for 17 or More Digits}

  cmp    edx, $002386f2          {10000000000000000 div $100000000}

  jne    @@Check17

  cmp    ecx, $6fc10000          {10000000000000000 mod $100000000}

@@Check17:

  jb     @@Test15or16

@@Test19:                        {Test for 19 Digits}

  cmp    edx, $0de0b6b3          {1000000000000000000 div $100000000}

  jne    @@Check19

  cmp    ecx, $a7640000          {1000000000000000000 mod $100000000}

@@Check19:

  jb     @@Test17or18

  mov    al, 19

  jmp    @@SetLength

@@Test17or18:                    {17 or 18 Digits}

  mov    bl, 18

  cmp    edx, $01634578          {100000000000000000 div $100000000}

  jne    @@SetLen

  cmp    ecx, $5d8a0000          {100000000000000000 mod $100000000}

  jmp    @@SetLen

@@Test15or16:                    {15 or 16 Digits}

  mov    bl, 16

  cmp    edx, $00038d7e          {1000000000000000 div $100000000}

  jne    @@SetLen

  cmp    ecx, $a4c68000          {1000000000000000 mod $100000000}

  jmp    @@SetLen

@@Test13:                        {Test for 13 or More Digits}

  cmp    edx, $000000e8          {1000000000000 div $100000000}

  jne    @@Check13

  cmp    ecx, $d4a51000          {1000000000000 mod $100000000}

@@Check13:

  jb     @@Test11

@@Test13or14:                    {13 or 14 Digits}

  mov    bl, 14

  cmp    edx, $00000918          {10000000000000 div $100000000}

  jne    @@SetLen

  cmp    ecx, $4e72a000          {10000000000000 mod $100000000}

  jmp    @@SetLen

@@Test11:                        {10, 11 or 12 Digits}

  cmp    edx, $02                {10000000000 div $100000000}

  jne    @@Check11

  cmp    ecx, $540be400          {10000000000 mod $100000000}

@@Check11:

  mov    bl, 11

  jb     @@SetLen                {10 Digits}

@@Test11or12:                    {11 or 12 Digits}

  mov    bl, 12

  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

@@SetLength:                     {Abs(Value) in EDX:ECX, Digits in EAX}

  push   ecx                     {Save Abs(Value)}

  push   edx

  lea    edx, [eax+ebp]          {Digits Needed (Including Sign Character)}

  mov    ecx, [edi]              {@Result}

  mov    esi, edx                {Digits Needed (Including Sign Character)}

  test   ecx, ecx

  je     @@NewStr                {Create New AnsiString for Result}

  cmp    dword ptr [ecx-8], 1

  jne    @@ChangeStr             {Reference Count <> 1}

  cmp    esi, [ecx-4]

  je     @@LengthOk              {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 AnsiString}

  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    @@LengthOk

@@ChangeStr:

  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(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)}

@@LengthOk:

  mov    edi, [edi]              {@Result}

  sub    esi, ebp                {Digits Needed (Excluding Sign Character)}

  mov    byte ptr [edi], '-'     {Store '-' Character (May be Overwritten)}

  add    edi, ebp                {Destination of 1st Digit}

  pop    edx                     {Restore Abs(Value)}

  pop    eax

  cmp    esi, 17

  jl     @@LessThan17Digits      {Digits < 17}

  je     @@SetDigit17            {Digits = 17}

  cmp    esi, 18

  je     @@SetDigit18            {Digits = 18}

  mov    cl, '0' - 1

  mov    ebx, $a7640000          {1000000000000000000 mod $100000000}

  mov    ebp, $0de0b6b3          {1000000000000000000 div $100000000}

@@CalcDigit19:

  add    ecx, 1

  sub    eax, ebx

  sbb    edx, ebp

  jnc    @@CalcDigit19

  add    eax, ebx

  adc    edx, ebp

  mov    [edi], cl

  add    edi, 1

@@SetDigit18:

  mov    cl, '0' - 1

  mov    ebx, $5d8a0000          {100000000000000000 mod $100000000}

  mov    ebp, $01634578          {100000000000000000 div $100000000}

@@CalcDigit18:

  add    ecx, 1

  sub    eax, ebx

  sbb    edx, ebp

  jnc    @@CalcDigit18

  add    eax, ebx

  adc    edx, ebp

  mov    [edi], cl

  add    edi, 1

@@SetDigit17:

  mov    cl, '0' - 1

  mov    ebx, $6fc10000          {10000000000000000 mod $100000000}

  mov    ebp, $002386f2          {10000000000000000 div $100000000}

@@CalcDigit17:

  add    ecx, 1

  sub    eax, ebx

  sbb    edx, ebp

  jnc    @@CalcDigit17

  add    eax, ebx

  adc    edx, ebp

  mov    [edi], cl

  add    edi, 1                  {Update Destination}

  mov    esi, 16                 {Set 16 Digits Left}

@@LessThan17Digits:              {Process Next 8 Digits}

  mov    ecx, 100000000          {EDX:EAX = Abs(Value) = Dividend}

  div    ecx

  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 Digits}

  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 Digits}

  mov    eax, ebp                {Remainder}

  sub    esi, 10                 {Digits Left - 2}

  jz     @@Last2Digits

@@SmallLoop:                     {Process Remaining Digits}

  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     @@SmallLoop             {Repeat Until Less than 2 Digits Remaining}

  jz     @@Last2Digits

  or     al , '0'                {Ascii Adjustment}

  mov    [edi], al               {Save Final Digit}

  jmp    @@Done

@@Last2Digits:

  movzx  eax, word ptr [TwoDigitLookup+eax*2]

  mov    [edi], ax               {Save Final 2 Digits}

@@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  @@TrimLeft                {Yes, Trim Leading Spaces}

  cmp  byte ptr [edx+ecx-1],' '  {S[Length(S)] <= ' '?}

  jbe  @@TrimRight               {Yes, Trim Trailing Spaces}

  jmp  System.@LStrLAsg          {No, Result := S (which occurs most time)}

@@TrimLeft:                      {Strip Leading Whitespace}

  dec  ecx

  jle  System.@LStrClr           {All Whitespace}

  inc  edx

  cmp  byte ptr [edx],' '

  jbe  @@TrimLeft

@@CheckDone:

  cmp  byte ptr [edx+ecx-1],' '

{$ifdef UNICODE}

  jbe  @@TrimRight

  push 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}

@@TrimRight:                     {Strip Trailing Whitespace}

  dec  ecx

  jmp  @@CheckDone

end;



{$endif FPC}  { these asm function had some low-level system.pas calls }



function CompareMem(P1, P2: Pointer; Length: Integer): Boolean;

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 @#: line 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;



{$ifndef ISDELPHI2007ANDUP}

{$endif ISDELPHI2007ANDUP}



{$endif LVCL}

{$endif PUREPASCAL}



{$ifdef PUREPASCAL} // from Aleksandr Sharahov's PosEx_Sha_Pas_2()

function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt = 1): Integer;

var len, lenSub: PtrInt;

    ch: AnsiChar;

    p, pSub, pStart, pStop: PUTF8Char;

label Loop0, Loop4, TestT, Test0, Test1, Test2, Test3, Test4,

      AfterTestT, AfterTest0, Ret, Exit;

begin;

  pSub := pointer(SubStr);

  p := pointer(S);

  if (p=nil) or (pSub=nil) or (Offset<1) then begin

    Result := 0;

    goto Exit;

  end;

  {$ifdef FPC}

  len := PStrRec(Pointer(PtrInt(p)-STRRECSIZE))^.length;

  lenSub := PStrRec(Pointer(PtrInt(pSub)-STRRECSIZE))^.length-1;

  {$else}

  len := PInteger(p-4)^;

  lenSub := PInteger(pSub-4)^-1;

  {$endif}

  if (len<lenSub+PtrInt(Offset)) or (lenSub<0) then begin

    Result := 0;

    goto Exit;

  end;

  pStop := p+len;

  p := p+lenSub;

  pSub := pSub+lenSub;

  pStart := p;

  p := p+Offset+3;

  ch := pSub[0];

  lenSub := -lenSub;

  if p<pStop then goto Loop4;

  p := p-4;

  goto Loop0;

Loop4:

  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;

Loop0:

  if ch=p[0] then goto Test0;

AfterTest0:

  if ch=p[1] then goto TestT;

AfterTestT:

  p := p+6;

  if p<pStop then goto Loop4;

  p := p-4;

  if p<pStop then goto Loop0;

  Result := 0;

  goto Exit;

Test3: p := p-2;

Test1: p := 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;

    len := len+2;

  until len>=0;

  p := p+2;

  if p<=pStop then goto Ret;

  Result := 0;

  goto Exit;

Test4: p := p-2;

Test2: p := p-2;

Test0: len := lenSub;

  if lenSub<>0 then

  repeat

    if (psub[len]<>p[len]) or (psub[len+1]<>p[len+1]) then

      goto AfterTest0;

    len := len+2;

  until len>=0;

  inc(p);

Ret:

  Result := p-pStart;

Exit:

end;

{$else}

function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt = 1): Integer;

asm  // eax=SubStr, edx=S, ecx=Offset

  push    ebx

  push    esi

  push    edx                 // @Str

  test    eax,eax

  jz      @@NotFound          // Exit if SubStr = ''

  test    edx,edx

  jz      @@NotFound          // Exit if Str = ''

  mov     esi,ecx

  mov     ecx,[edx-4]         // Length(Str)

  mov     ebx,[eax-4]         // Length(Search string)

  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      @@NotFound          // StartPos > Max Start Pos

  cmp     ebx,1               // Length(SubStr)

  jle     @@SingleChar        // Length(SubStr) <= 1

  push    edi

  push    ebp

  lea     edi,[ebx-2]         // edi = Length(Search string) - 2

  mov     esi,eax             // esi = Search string

  movzx   ebx,byte ptr [eax]  // bl = Search Character

@@Loop:                       // Compare 2 Characters per Loop

  cmp     bl,[edx]

  je      @@Char1Found

@@NotChar1:

  cmp     bl,[edx+1]

  je      @@Char2Found

@@NotChar2:

  lea     edx,[edx+2]

  cmp     edx,ecx             // Next Start Position <= Max Start Position

  jle     @@Loop

  pop     ebp

  pop     edi

@@NotFound:

  xor     eax,eax            // returns 0 if not found

  pop     edx

  pop     esi

  pop     ebx

  ret

@@Char1Found:

  mov     ebp,edi             // ebp = Length(Search string) - 2

@@Char1Loop:

  movzx   eax,word ptr [esi+ebp]

  cmp     ax,[edx+ebp]       // Compare 2 Chars per Char1Loop (may include #0)

  jne     @@NotChar1

  sub     ebp,2

  jnc     @@Char1Loop

  pop     ebp

  pop     edi

  jmp     @@SetResult

@@Char2Found:

  mov     ebp,edi             // ebp = Length(Search string) - 2

@@Char2Loop:

  movzx   eax,word ptr [esi+ebp]

  cmp     ax,[edx+ebp+1]     // Compare 2 Chars per Char2Loop (may include #0)

  jne     @@NotChar2

  sub     ebp,2

  jnc     @@Char2Loop

  pop     ebp

  pop     edi

  jmp     @@CheckResult

@@SingleChar:

  jl      @@NotFound          // Needed for Zero-Length Non-NIL Strings

  movzx   eax,byte ptr [eax]  // Search Character

@@CharLoop:

  cmp     al,[edx]

  je      @@SetResult

  cmp     al,[edx+1]

  je      @@CheckResult

  lea     edx,[edx+2]

  cmp     edx,ecx

  jle     @@CharLoop

  jmp     @@NotFound

@@CheckResult:                // Check within AnsiString

  cmp     edx,ecx

  jge     @@NotFound

  add     edx,1

@@SetResult:

  pop     ecx                 // @Str

  pop     esi

  pop     ebx

  neg     ecx

  lea     eax,[edx+ecx+1]

end;

{$endif PUREPASCAL}



function Split(const Str, SepStr: RawUTF8; StartPos: integer): RawUTF8;

var i: integer;

begin

  i := PosEx(SepStr,Str,StartPos);

  if i>0 then

    result := Copy(Str,StartPos,i-StartPos) else

    if StartPos=1 then

      result := Str else

      result := Copy(Str,StartPos,maxInt);

end;



procedure Split(const Str, SepStr: RawUTF8; var LeftStr, RightStr: RawUTF8; ToUpperCase: boolean);

var i: integer;

    tmp: RawUTF8; // may be called as Split(Str,SepStr,Str,RightStr)

begin

  i := PosEx(SepStr,Str);

  if i=0 then begin

    LeftStr := Str;

    RightStr := '';

  end else begin

    tmp := copy(Str,1,i-1);

    RightStr := copy(Str,i+length(SepStr),maxInt);

    LeftStr := tmp;

  end;

  if ToUpperCase then begin

    LeftStr := UpperCaseU(LeftStr);

    RightStr := UpperCaseU(RightStr);

  end;

end;



function Split(const Str, SepStr: RawUTF8; var LeftStr: RawUTF8; ToUpperCase: boolean=false): RawUTF8; overload;

begin

  Split(Str,SepStr,LeftStr,result,ToUpperCase);

end;



procedure Split(const Str: RawUTF8; const SepStr: array of RawUTF8;

  const DestPtr: array of PRawUTF8);

var s,i,j,n: integer;

begin

  j := 1;

  n := 0;

  s := 0;

  if high(SepStr)>=0 then

    while n<=high(DestPtr) do begin

      i := PosEx(SepStr[s],Str,j);

      if i=0 then begin

        if DestPtr[n]<>nil then

          DestPtr[n]^ := copy(Str,j,MaxInt);

        inc(n);

        break;

      end;

      if DestPtr[n]<>nil then

        DestPtr[n]^ := copy(Str,j,i-j);

      inc(n);

      if s<high(SepStr) then

        inc(s);

      j := i+1;

    end;

  for i := n to high(DestPtr) do

    if DestPtr[i]<>nil then

      DestPtr[i]^ := '';

end;



function StringReplaceAll(const S, OldPattern, NewPattern: RawUTF8): RawUTF8;



  procedure Process(j: integer);

  var oldlen,newlen,i,last,posCount,sharedlen: integer;

      pos: TIntegerDynArray;

      src,dst: PAnsiChar;

  begin

    oldlen := length(OldPattern);

    newlen := length(NewPattern);

    SetLength(pos,64);

    pos[0] := j;

    posCount := 1;

    repeat

      j := PosEx(OldPattern,S,j+oldlen);

      if j=0 then

        break;

      AddInteger(pos,posCount,j);

    until false;

    SetString(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);

      MoveFast(pointer(NewPattern)^,dst^,newlen);

      inc(dst,newlen);

      last := pos[i]+oldlen;

    end;

    MoveFast(src^,dst^,length(S)-last+1);

  end;



var j: integer;

begin

  if (S='') or (OldPattern='') or (OldPattern=NewPattern) then

    result := S else begin

    j := PosEx(OldPattern, S, 1); // our PosEx() is faster than Pos()

    if j=0 then

      result := S else

      Process(j);

  end;

end;



function StringReplaceTabs(const Source,TabText: RawUTF8): RawUTF8;



  procedure Process(S,D,T: PAnsiChar; TLen: integer);

  begin

    repeat

      if S^=#0 then

        break else

      if S^<>#9 then begin

        D^ := S^;

        inc(D);

        inc(S);

      end else begin

        MoveFast(T^,D^,TLen);

        inc(D,TLen);

        inc(S);

      end;

    until false;

  end;



var L,i,n,ttl: integer;

begin

  ttl := length(TabText);

  L := Length(Source);

  n := 0;

  if ttl<>0 then

    for i := 1 to L do

      if Source[i]=#9 then

        inc(n);

  if n=0 then begin

    result := Source;

    exit;

  end;

  SetLength(result,L+n*pred(ttl));

  Process(pointer(Source),pointer(result),pointer(TabText),ttl);

end;



function PosChar(Str: PUTF8Char; Chr: AnsiChar): PUTF8Char;

{$ifdef PUREPASCAL}

begin

  result := nil;

  if Str<>nil then begin

    repeat

      if Str^=#0 then

        exit else

      if Str^=Chr then

        break;

      inc(Str);

      if Str^=#0 then

        exit else

      if Str^=Chr then

        break;

      inc(Str);

    until false;

    result := Str;

  end;

end;

{$else}

asm // faster version by AB - eax=Str dl=Chr

    test eax,eax

    jz @z

@1: mov ecx,[eax]

    cmp cl,dl

    jz @z

    lea eax,[eax+1]

    test cl,cl

    jz @e

    cmp ch,dl

    jz @z

    lea eax,[eax+1]

    test ch,ch

    jnz @1

@e: xor eax,eax

@z:

end;

{$endif}



function PosCharAny(Str: PUTF8Char; Characters: PAnsiChar): PUTF8Char;

var s: PAnsiChar;

    c: AnsiChar;

begin

  if (Str<>nil) and (Characters<>nil) 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: integer;

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

        SetString(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 PosI(uppersubstr: PUTF8Char; const str: RawUTF8): Integer;

var C: AnsiChar;

begin

  if uppersubstr<>nil then begin

    C := uppersubstr^;

    for result := 1 to Length(str) do

      if NormToUpperAnsi7[str[result]]=C then

        if IdemPChar(@PUTF8Char(pointer(str))[result],PAnsiChar(uppersubstr)+1) then

          exit;

  end;

  result := 0;

end;



function StrPosI(uppersubstr,str: PUTF8Char): PUTF8Char;

var C: AnsiChar;

begin

  if (uppersubstr<>nil) and (str<>nil) then begin

    C := uppersubstr^;

    result := str;

    while result^<>#0 do begin

      if NormToUpperAnsi7[result^]=C then

        if IdemPChar(result+1,PAnsiChar(uppersubstr)+1) then

          exit;

      inc(result);

    end;

  end;

  result := nil;

end;





function PosIU(substr: PUTF8Char; const str: RawUTF8): Integer;

var p: PUTF8Char;

begin

  if (substr<>nil) and (str<>'') then begin

    p := pointer(str);

    repeat

      if GetNextUTF8Upper(p)=ord(substr^) then

        if IdemPCharU(p,substr+1) then begin

          result := p-pointer(str);

          exit;

        end;

    until p^=#0;

  end;

  result := 0;

end;



procedure AppendCharToRawUTF8(var Text: RawUTF8; Ch: AnsiChar);

var L: integer;

begin

  L := length(Text);

  SetLength(Text,L+1);

  PByteArray(Text)[L] := ord(Ch);

end;



procedure AppendBufferToRawUTF8(var Text: RawUTF8; Buffer: pointer; BufferLen: PtrInt);

var L: PtrInt;

begin

  if BufferLen<=0 then

    exit;

  L := PtrInt(Text);

  if L<>0 then

    L := PStrRec(Pointer(L-STRRECSIZE))^.length;

  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: integer;

    lens: array[0..63] of integer;

    P: PUTF8Char;

begin

  if high(Buffers)>high(lens) then

    raise ESynException.Create('Too many params in AppendBuffersToRawUTF8()');

  len := 0;

  for i := 0 to high(Buffers) do begin

    lens[i] := StrLen(Buffers[i]);

    inc(len,lens[i]);

  end;

  TextLen := Length(Text);

  SetLength(Text,TextLen+len);

  P := pointer(Text);

  inc(P,TextLen);

  for i := 0 to high(Buffers) do

  if Buffers[i]<>nil then begin

    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 := PtrInt(Text);

  if L<>0 then begin

    L := PStrRec(Pointer(L-STRRECSIZE))^.length;

    MoveFast(Pointer(Text)^,Buffer^,L);

    inc(Buffer,L);

  end;

  result := Buffer;

end;



function QuotedStr(const S: RawUTF8; Quote: AnsiChar): RawUTF8;

begin

  QuotedStr(Pointer(S),Quote,result);

end;



function QuotedStr(Text: PUTF8Char; Quote: AnsiChar): RawUTF8;

begin

  QuotedStr(Text,Quote,result);

end;



procedure QuotedStr(Text: PUTF8Char; Quote: AnsiChar; var result: RawUTF8);

var n, L, first: integer;

    P: PUTF8Char;

label quot;

begin

  n := 0;

  L := 0;

  first := n;

  if Text<>nil then begin

    P := Text;

    repeat

      if P[L]=#0 then

        break else

      if P[L]<>Quote then begin

        inc(L);

        continue;

      end;

      first := L;

      inc(L);

      inc(n);

      repeat

        if P[L]=#0 then

          break else

        if P[L]<>Quote then begin

          inc(L);

          continue;

        end;

        inc(L);

        inc(n);

      until false;

      break;

    until false;

  end;

  FastNewRawUTF8(result,L+n+2);

  P := pointer(Result);

  P^ := Quote;

  inc(P);

  if n=0 then begin

    MoveFast(Text^,P^,L);

    inc(P,L);

  end else begin

    MoveFast(Text^,P^,first);

    n := first;

    L := first;

    goto quot;

    repeat

      if Text[L]=#0 then

        break else

      if Text[L]<>Quote then begin

        P[n] := Text[L];

        inc(L);

        inc(n);

      end else begin

quot:   PWord(P+n)^ := ord(Quote)+ord(Quote) shl 8;

        inc(L);

        inc(n,2);

      end;

    until false;

    inc(P,n);

  end;

  P^ := Quote;

  //Assert(P-pointer(Result)+1=length(result));

end;



function GotoEndOfQuotedString(P: PUTF8Char): PUTF8Char;

var quote: AnsiChar;

begin // P^='"' at function call

  quote := P^;

  inc(P);

  repeat

    if P^=#0 then

      break else

    if P^<>quote then

      inc(P) else

      if P[1]=quote then // allow double quotes inside string

        inc(P,2) else

        break; // end quote

  until false;

  result := P;

end; // P^='"' at function return



procedure QuotedStrJSON(const aText: RawUTF8; var result: RawUTF8);

var i: integer;

begin

  for i := 1 to length(aText) do

    case aText[i] of

    #0..#31,'\','"':

      with TTextWriter.CreateOwnedStream do

      try

        Add('"');

        AddJSONEscape(pointer(aText));

        Add('"');

        SetText(result);

        exit;

      finally

        Free;

      end;

    end;

  // if we reached here, no character needs to be escaped in this string

  result := '"'+aText+'"';

end;



function GotoEndOfJSONString(P: PUTF8Char): PUTF8Char;

begin // P^='"' at function call

  inc(P);

  repeat

    if P^=#0 then

      break else

    if P^<>'\' then

      if P^<>'"' 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

  if P^ in [#1..' '] then

    repeat

      inc(P)

    until not(P^ in [#1..' ']);

  result := P;

end;



function NextNotSpaceCharIs(var P: PUTF8Char; ch: AnsiChar): boolean;

begin

  if P^ in [#1..' '] then

    repeat

      inc(P)

    until not(P^ in [#1..' ']);

  if P^=ch then begin

    inc(P);

    result := true;

  end else

    result := false;

end;



function UnQuoteSQLStringVar(P: PUTF8Char; out Value: RawUTF8): PUTF8Char;

var quote: AnsiChar;

    PBeg, PS: PUTF8Char;

    n: PtrInt;

begin

  if P=nil then begin

    result := nil;

    exit;

  end;

  quote := P^;

  inc(P);

  // compute unquoted string length

  PBeg := P;

  n := 0;

  repeat

    if P^=#0 then

      break;

    if P^<>quote then

      inc(P) else

      if P[1]=quote then begin

        inc(P,2); // allow double quotes inside string

        inc(n);

      end else

        break; // end quote

  until false;

  if P^=#0 then begin

    result := nil; // end of string before end quote -> incorrect

    exit;

  end;

  // create unquoted string

  if n=0 then

    // no quote within

    SetRawUTF8(Value,PAnsiChar(PBeg),P-PBeg) else begin

    // unescape internal quotes

    SetLength(Value,P-PBeg-n);

    P := PBeg;

    PS := Pointer(Value);

    repeat

      if P^=quote then

        if P[1]=quote then

          inc(P) else // allow double quotes inside string

          break; // end quote

      PS^ := P^;

      inc(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);

    if IdemPChar(P,'SELECT ') then begin

      if SelectClause<>nil then begin

        inc(P,7);

        from := StrPosI(' FROM ',P);

        if from=nil then

          SelectClause^ := '' else

          SetString(SelectClause^,PAnsiChar(P),from-P);

      end;

      result := true;

    end else

    result := IdemPChar(P,'EXPLAIN ') or

      ((IdemPChar(P,'VACUUM') or IdemPChar(P,'PRAGMA')) and (P[6] in [#0..' ',';'])) or

      (((IdemPChar(P,'WITH') ) and (P[4] in [#0..' ',';'])) and

        not (ContainsUTF8(P,'INSERT') or ContainsUTF8(P,'UPDATE') or

             ContainsUTF8(P,'DELETE')));

  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);

begin // '\uFFF0base64encodedbinary' decode into binary (input shall have been checked)

  ParamValue := Base64ToBin(PAnsiChar(pointer(ParamValue))+3,length(ParamValue)-3);

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 begin

      Blob := Base64ToBin(PAnsiChar(Value)+3,ValueLen);

      result := true;

    end 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 begin

      Base64ToBin(PAnsiChar(Value)+3,ValueLen,Blob);

      result := true;

    end 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 begin

    Blob := Base64ToBin(PAnsiChar(Value)+3,ValueLen-3);

    result := true;

  end;

end;



const

  NULL_LOW  = ord('n')+ord('u')shl 8+ord('l')shl 16+ord('l')shl 24;

  FALSE_LOW = ord('f')+ord('a')shl 8+ord('l')shl 16+ord('s')shl 24;

  TRUE_LOW  = ord('t')+ord('r')shl 8+ord('u')shl 16+ord('e')shl 24;

  NULL_UPP  = ord('N')+ord('U')shl 8+ord('L')shl 16+ord('L')shl 24;



  EndOfJSONValueField = [#0,#9,#10,#13,' ',',','}',']'];

  EndOfJSONField = [',',']','}',':'];

  DigitChars = ['-','+','0'..'9'];

  DigitFirstChars = ['-','1'..'9']; // 0/- excluded by JSON!

  DigitFloatChars = ['-','+','0'..'9','.','E','e'];





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;

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  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

        ParamValue := copy(ParamValue,4,L); // return 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;

    SetRawUTF8(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;

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  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;

  SetString(result,PAnsiChar(pointer(SQL)),length(SQL));

  // compute GenericSQL from SQL, converting :(...): into ?

  Gen := PUTF8Char(pointer(result))+ppBeg-1; // Gen^ just before :(

  P := PUTF8Char(pointer(SQL))+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 the correct SQL statement, with params in Values[]

  SetLength(result,Gen-pointer(result));

  inc(maxParam);

end;





{$ifndef DEFINED_INT32TOUTF8}



function Int32ToUTF8(Value : integer): RawUTF8; // faster than SysUtils.IntToStr

var tmp: array[0..15] of AnsiChar;

    P: PAnsiChar;

begin

  P := StrInt32(@tmp[15],Value);

  SetString(result,P,@tmp[15]-P);

end;



function Int64ToUtf8(Value: Int64): RawUTF8; // faster than SysUtils.IntToStr

var tmp: array[0..23] of AnsiChar;

    P: PAnsiChar;

begin

  P := StrInt64(@tmp[23],Value);

  SetString(result,P,@tmp[23]-P);

end;



function Trim(const S: RawUTF8): RawUTF8;

var I,L: Integer;

begin

  L := Length(S);

  I := 1;

  while (I<=L) and (S[I]<=' ') do inc(I);

  if I>L then

    result := '' else

  if (I=1) and (S[L]>' ') then

    result := S else begin

    while S[L]<=' ' do dec(L);

    result := Copy(S,I,L-I+1);

  end;

end;



{$endif}



{$ifndef CPU64} // already implemented by ToUTF8(Value: PtrInt) below

function ToUTF8(Value: Int64): RawUTF8;

var tmp: array[0..23] of AnsiChar;

    P: PAnsiChar;

begin

  P := StrInt64(@tmp[23],Value);

  SetString(result,P,@tmp[23]-P);

end;

{$endif}



function ToUTF8(Value: PtrInt): RawUTF8;

var tmp: array[0..15] of AnsiChar;

    P: PAnsiChar;

begin

  P := StrInt32(@tmp[15],Value);

  SetString(result,P,@tmp[15]-P);

end;



function UInt32ToUTF8(Value: Cardinal): RawUTF8;

var tmp: array[0..15] of AnsiChar;

    P: PAnsiChar;

begin

  P := StrUInt32(@tmp[15],Value);

  SetString(result,P,@tmp[15]-P);

end;



procedure UInt32ToUtf8(Value: cardinal; var result: RawUTF8);

var tmp: array[0..15] of AnsiChar;

    P: PAnsiChar;

begin

  P := StrUInt32(@tmp[15],Value);

  SetRawUTF8(result,P,@tmp[15]-P);

end;



{$ifndef EXTENDEDTOSTRING_USESTR}

var // standard FormatSettings (US)

    SettingsUS: TFormatSettings;

{$endif}



function ExtendedToString(var S: ShortString; Value: TSynExtended;

  Precision: integer): integer;

{$ifdef EXTENDEDTOSTRING_USESTR}

var i,prec: integer;

begin

  str(Value:0:Precision,S); // not str(Value:0,S) -> '  0.0E+0000'

  // using str() here avoid FloatToStrF() usage -> LVCL is enough

  result := length(S);

  prec := result; // if no decimal

  if S[1]='-' then

    dec(prec);

  for i := 2 to result do // test if scientific format -> return as this

    case S[i] of

    'E': exit;  // pos('E',S)>0; which Delphi 2009+ don't like

    '.': dec(prec);

    end;

  if (prec>=Precision) and (prec<>result) then begin

    dec(result,prec-Precision);

    if S[result+1]>'5' then begin // manual rounding

      prec := result;

      repeat

        case S[prec] of

        '.': ; // just ignore decimal separator

        '0'..'8': begin

          inc(S[prec]);

          break;

        end;

        '9': begin

          S[prec] := '0';

          if ((prec=2) and (S[1]='-')) or (prec=1) then begin

            MoveFast(S[prec],S[prec+1],result);

            S[prec] := '1';

            break;

          end;

        end;

        else break;

        end;

        dec(prec);

      until prec=0;

    end; // note: this fixes http://stackoverflow.com/questions/2335162

  end;

  while S[result]='0' do begin

    dec(result); // trunc any trimming 0

    if S[result]='.' then begin

      dec(result);

      if (result=2) and (S[1]='-') and (S[2]='0') then begin

        result := 1;

        S[1] := '0'; // '-0.000' -> '0'

      end;

      break; // decimal were all '0' -> return only integer part

    end;

  end;

{$else}

{$ifdef UNICODE}

var i: integer;

{$endif}

begin

  // use ffGeneral: see http://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}

{$endif EXTENDEDTOSTRING_USESTR}

end;



function ExtendedToStr(Value: TSynExtended; Precision: integer): RawUTF8;

var tmp: ShortString;

begin

  if Value=0 then

    result := '0' else

    SetRawUTF8(result,@tmp[1],ExtendedToString(tmp,Value,Precision));

end;



procedure ExtendedToStr(Value: TSynExtended; Precision: integer;

  var result: RawUTF8);

var tmp: ShortString;

begin

  if Value=0 then

    result := '0' else

    SetRawUTF8(result,@tmp[1],ExtendedToString(tmp,Value,Precision));

end;



function DoubleToStr(Value: Double): RawUTF8;

var tmp: ShortString;

begin

  if Value=0 then

    result := '0' else

    SetRawUTF8(result,@tmp[1],ExtendedToString(tmp,Value,DOUBLE_PRECISION));

end;



function FormatUTF8(const Format: RawUTF8; const Args: array of const): RawUTF8;

begin

  FormatUTF8(Format,Args,result);

end;



procedure FormatUTF8(const Format: RawUTF8; const Args: array of const;

  var result: RawUTF8);

// only supported token is %, with any const arguments

var i, blocksN, L, argN: PtrInt;

    tmpStr: TRawUTF8DynArray;

    F,FDeb: PUTF8Char;

    blocks: array[0..49] of TTempUTF8;

begin

  if (Format='') or (high(Args)<0) then begin

    result := Format; // no formatting to process

    exit;

  end;

  if Format='%' then begin

    VarRecToUTF8(Args[0],result); // optimize raw conversion

    exit;

  end;

  result := '';

  if length(Args)*2+1>high(blocks) then

    raise ESynException.Create('FormatUTF8: too many args (max=25)!');

  SetLength(tmpStr,length(Args));

  blocksN := 0;

  argN := 0;

  L := 0;

  F := pointer(Format);

  while F^<>#0 do begin

    if F^<>'%' then begin

      FDeb := F;

      while (F^<>'%') and (F^<>#0) do inc(F);

      with blocks[blocksN] do begin

        Text := FDeb;

        Len := F-FDeb;

        inc(L,Len);

        inc(blocksN);

      end;

    end;

    if F^=#0 then break;

    inc(F); // jump '%'

    if argN<=high(Args) then begin

      inc(L,VarRecToTempUTF8(Args[argN],tmpStr[argN],blocks[blocksN]));

      inc(blocksN);

      inc(argN);

    end else

    if F^<>#0 then begin // no more available Args -> add all remaining text

      with blocks[blocksN] do begin

        Text := F;

        Len := StrLen(F);

        inc(L,Len);

        inc(blocksN);

      end;

      break;

    end;

  end;

  if L=0 then

    exit;

  SetLength(result,L);

  F := pointer(result);

  for i := 0 to blocksN-1 do begin

    MoveFast(blocks[i].Text^,F^,blocks[i].Len);

    inc(F,blocks[i].Len);

  end;

end;



function FormatUTF8(const Format: RawUTF8; const Args, Params: array of const; JSONFormat: boolean): RawUTF8; overload;

var i, tmpN, L, A, P, len: PtrInt;

    isParam: AnsiChar;

    tmp: TRawUTF8DynArray;

    inlin: set of 0..255;

    F,FDeb: PUTF8Char;

    wasString: Boolean;

const QUOTECHAR: array[boolean] of AnsiChar = ('''','"');

      NOTTOQUOTE: array[boolean] of set of 0..31 = (

        [vtBoolean,vtInteger,vtInt64,vtCurrency,vtExtended],

        [vtBoolean,vtInteger,vtInt64,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

    SetString(result,PAnsiChar(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);

  {$ifdef FPC}

  try // alf: to circumvent FPC issues

  {$endif}

  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);

        SetString(tmp[tmpN],FDeb,len); // add inbetween text

        inc(tmpN);

      end;

    end;

    if F^=#0 then

      break;

    isParam := F^;

    inc(F); // jump '%' or '?'

    if (isParam='%') and (A<=high(Args)) then begin // handle % substitution

      if tmpN=length(tmp) then

        SetLength(tmp,tmpN+8);

      VarRecToUTF8(Args[A],tmp[tmpN]);

      inc(A);

      if tmp[tmpN]<>'' then begin

        inc(L,length(tmp[tmpN]));

        inc(tmpN);

      end;

    end else

    if (isParam='?') and (P<=high(Params)) then begin // handle ? substitution

      if tmpN=length(tmp) then

        SetLength(tmp,tmpN+8);

      {$ifndef NOVARIANTS}

      if JSONFormat and (Params[P].VType=vtVariant) then

        VariantSaveJSON(Params[P].VVariant^,twJSONEscape,tmp[tmpN]) else

      {$endif}

      begin

        VarRecToUTF8(Params[P],tmp[tmpN]);

        wasString := not (Params[P].VType in NOTTOQUOTE[JSONFormat]);

        if wasString then

          if JSONFormat then

            QuotedStrJSON(tmp[tmpN],tmp[tmpN]) else

            tmp[tmpN] := QuotedStr(pointer(tmp[tmpN]),'''');

        if not JSONFormat then begin

          inc(L,4); // space for :():

          include(inlin,tmpN);

        end;

      end;

      inc(P);

      inc(L,length(tmp[tmpN]));

      inc(tmpN);

    end else

    if F^<>#0 then begin // no more available Args -> add all remaining text

      FDeb := F;

      repeat inc(F) until (F^=#0);

      goto Txt;

    end;

  end;

  if L=0 then

    exit;

  if (not JSONFormat) and (tmpN>SizeOf(inlin)shl 3) then

    raise ESynException.CreateUTF8(

      'Too many parameters for FormatUTF8(): %>%',[tmpN,SizeOf(inlin)shl 3]);

  SetLength(result,L);

  F := pointer(result);

  for i := 0 to tmpN-1 do

  if tmp[i]<>'' then begin

    if i in inlin then begin

      PWord(F)^ := ord(':')+ord('(')shl 8;

      inc(F,2);

    end;

    {$ifdef FPC}

    L := PStrRec(Pointer(PtrInt(tmp[i])-STRRECSIZE))^.length;

    {$else}

    L := PInteger(PtrInt(tmp[i])-sizeof(integer))^;

    {$endif}

    MoveFast(pointer(tmp[i])^,F^,L);

    inc(F,L);

    if i in inlin then begin

      PWord(F)^ := ord(')')+ord(':')shl 8;

      inc(F,2);

    end;

  end;

  {$ifdef FPC}

  finally

    finalize(tmp);

  end;

  {$endif}

end;



function RawByteStringArrayConcat(const Values: array of RawByteString): RawByteString;

var i, L: integer;

    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);

var HResInfo: THandle;

    HGlobal: THandle;

begin

  HResInfo := FindResource(HInstance,PChar(ResName),ResType);

  if HResInfo=0 then

    exit;

  HGlobal := LoadResource(HInstance,HResInfo);

  if HGlobal<>0 then

    SetString(buf,PAnsiChar(LockResource(HGlobal)),SizeofResource(HInstance,HResInfo));

end;



procedure ResourceSynLZToRawByteString(const ResName: string;

  out buf: RawByteString);

var HResInfo: THandle;

    HGlobal: THandle;

begin

  HResInfo := FindResource(HInstance,PChar(ResName),PChar(10));

  if HResInfo=0 then

    exit;

  HGlobal := LoadResource(HInstance,HResInfo);

  if HGlobal<>0 then // direct decompression from memory mapped .exe content

    SynLZDecompress(LockResource(HGlobal),SizeofResource(HInstance,HResInfo),buf);

end;



function StrIComp(Str1, Str2: pointer): PtrInt;

{$ifdef PUREPASCAL}

var C1, C2: AnsiChar;

begin

  if Str1<>Str2 then

  if Str1<>nil then

  if Str2<>nil then begin

    repeat

      C1 := PAnsiChar(Str1)^;

      C2 := PAnsiChar(Str2)^;

      if C1 in ['a'..'z'] then dec(C1,32);

      if C2 in ['a'..'z'] then dec(C2,32);

      if (C1<>C2) or (C1=#0) then

        break;

      Inc(PtrUInt(Str1));

      Inc(PtrUInt(Str2));

    until false;

    Result := Ord(C1) - Ord(C2);

  end else

  result := 1 else  // Str2=''

  result := -1 else // Str1=''

  result := 0;      // Str1=Str2

end;

{$else}

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;

{$endif}



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 StrLenPas(S: pointer): PtrInt;

begin

  result := 0;

  if S<>nil then

  while true do

    if PAnsiChar(S)[result+0]<>#0 then

    if PAnsiChar(S)[result+1]<>#0 then

    if PAnsiChar(S)[result+2]<>#0 then

    if PAnsiChar(S)[result+3]<>#0 then

      inc(result,4) else begin

      inc(result,3);

      exit;

    end else begin

      inc(result,2);

      exit;

    end else begin

      inc(result);

      exit;

    end else

      exit;

end;



function StrComp(Str1, Str2: pointer): PtrInt;

begin

  if Str1<>Str2 then

  if Str1<>nil then

  if Str2<>nil then begin

    if PByte(Str1)^=PByte(Str2)^ then

      repeat

        if PByte(Str1)^=0 then break;

        inc(PByte(Str1));

        inc(PByte(Str2));

      until PByte(Str1)^<>PByte(Str2)^;

    result := PByte(Str1)^-PByte(Str2)^;

    exit;

  end else

  result := 1 else  // Str2=''

  result := -1 else // Str1=''

  result := 0;      // Str1=Str2

end;



function StrCompFast(Str1, Str2: pointer): PtrInt;

begin

  if Str1<>Str2 then

  if Str1<>nil then

  if Str2<>nil then begin

    if PByte(Str1)^=PByte(Str2)^ then

      repeat

        if PByte(Str1)^=0 then break;

        inc(PByte(Str1));

        inc(PByte(Str2));

      until PByte(Str1)^<>PByte(Str2)^;

    result := PByte(Str1)^-PByte(Str2)^;

    exit;

  end else

  result := 1 else  // Str2=''

  result := -1 else // Str1=''

  result := 0;      // Str1=Str2

end;



{$else}



function StrLenPas(S: pointer): PtrInt;

asm // slower than x86/SSE* StrLen(), but won't read any byte beyond the string

    test eax,eax

    mov edx,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;

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]

        test  cl,cl

        lea   eax,[eax+1]

        lea   edx,[edx+1]

        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;

asm // warning: may read up to 15 bytes beyond the string itself

      test      eax,edx

      jz        @n

@ok:  sub       eax,edx

      jz        @0

      {$ifdef HASAESNI}

      movdqu    xmm0,dqword [edx]

      pcmpistri xmm0,dqword [edx+eax],EQUAL_EACH+NEGATIVE_POLARITY // result in ecx

      {$else}

      db $F3,$0F,$6F,$02

      db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY

      {$endif}

      ja        @1

      jc        @2

      xor       eax,eax

      ret

@1:   add       edx,16

      {$ifdef HASAESNI}

      movdqu    xmm0,dqword [edx]

      pcmpistri xmm0,dqword [edx+eax],EQUAL_EACH+NEGATIVE_POLARITY // result in ecx

      {$else}

      db $F3,$0F,$6F,$02

      db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY

      {$endif}

      ja        @1

      jc        @2

@0:   xor       eax,eax // Str1=Str2

      ret

@n:   cmp       eax,edx

      je        @0

      test      eax,eax  // Str1='' ?

      jz        @max

      test      edx,edx  // Str2='' ?

      jnz       @ok

      mov       eax,1

      ret

@max: dec       eax

      ret

@2:   add       eax,edx

      movzx     eax,byte ptr [eax+ecx]

      movzx     edx,byte ptr [edx+ecx]

      sub       eax,edx

end;



function SortDynArrayAnsiStringSSE42(const A,B): integer;

asm // warning: may read up to 15 bytes beyond the string itself

      mov       eax,[eax]

      mov       edx,[edx]

      test      eax,edx

      jz        @n

@ok:  sub       eax,edx

      jz        @0

      {$ifdef HASAESNI}

      movdqu    xmm0,dqword [edx]

      pcmpistri xmm0,dqword [edx+eax],EQUAL_EACH+NEGATIVE_POLARITY // result in ecx

      {$else}

      db $F3,$0F,$6F,$02

      db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY

      {$endif}

      ja        @1

      jc        @2

      xor       eax,eax

      ret

@1:   add       edx,16

      {$ifdef HASAESNI}

      movdqu    xmm0,dqword [edx]

      pcmpistri xmm0,dqword [edx+eax],EQUAL_EACH+NEGATIVE_POLARITY // result in ecx

      {$else}

      db $F3,$0F,$6F,$02

      db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY

      {$endif}

      ja        @1

      jc        @2

@0:   xor       eax,eax // Str1=Str2

      ret

@n:   cmp       eax,edx

      je        @0

      test      eax,eax  // Str1='' ?

      jz        @max

      test      edx,edx  // Str2='' ?

      jnz       @ok

      or        eax,-1

      ret

@max: inc       eax

      ret

@2:   add       eax,edx

      movzx     eax,byte ptr [eax+ecx]

      movzx     edx,byte ptr [edx+ecx]

      sub       eax,edx

end;



{$endif PUREPASCAL}



function IdemPropNameU(const P1,P2: RawUTF8): boolean;

{$ifdef PUREPASCAL}

var i,j,L: integer;

begin

  result := false;

  L := length(P1);

  if L<>length(P2) then

    exit;

  j := 1;

  for i := 1 to L shr 2 do

    if (PCardinal(@P1[j])^ xor PCardinal(@P2[j])^) and $dfdfdfdf<>0 then

      exit else

      inc(j,4);

  for i := j to L do

    if (ord(P1[i]) xor ord(P2[i])) and $df<>0 then

      exit;

  result := true;

end;

{$else}

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;

{$endif}



function IdemPropName(const P1,P2: shortstring): boolean; overload;

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: integer): boolean; overload;

begin

  if ord(P1[0])=P2Len then

    result := IdemPropNameUSameLen(@P1[1],P2,P2Len) else

    result := false;

end;



function IdemPropName(P1,P2: PUTF8Char; P1Len,P2Len: integer): boolean; overload;

begin

  if P1Len=P2Len then

    result := IdemPropNameUSameLen(P1,P2,P2Len) else

    result := false;

end;



function IdemPropNameU(const P1: RawUTF8; P2: PUTF8Char; P2Len: integer): boolean;

begin

  if length(P1)=P2Len then

    result := IdemPropNameUSameLen(pointer(P1),P2,P2Len) else

    result := false;

end;



function IdemPropNameUSameLen(P1,P2: PUTF8Char; P1P2Len: integer): boolean;

{$ifdef PUREPASCAL}

var i,j: integer;

begin

  result := false;

  j := 0;

  for i := 1 to P1P2Len shr 2 do

    if (PCardinal(PtrInt(P1)+j)^ xor PCardinal(@P2[j])^) and $dfdfdfdf<>0 then

      exit else

      inc(j,4);

  for i := j to P1P2Len-1 do

    if (PByteArray(P1)^[i] xor ord(P2[i])) and $df<>0 then

      exit;

  result := true;

end;

{$else}

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;

{$endif}





{$ifdef MSWINDOWS}

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}



function GetSystemTimeMillisecondsForXP: Int64; stdcall;

var fileTime: TFileTime;

begin

   GetSystemTimeAsFileTime(fileTime); // very fast, with 100 ns unit

   {$ifdef CPU64} // 64 bit XP ? not very likely - but who knows :)

   // http://msdn.microsoft.com/en-us/library/windows/desktop/ms724284 states:

   // do not cast a pointer to a FILETIME structure to either a int64* value

   // because it can cause alignment faults on 64-bit Windows -> manual compute

   result := fileTime.dwHighDateTime;

   result := (result shl 32)+fileTime.dwLowDateTime;

   result := result div 10000;

   {$else}

   result := trunc(PInt64(@fileTime)^/10000); // 100 ns unit

   {$endif}

end;



{$ifdef FPC} // oddly not defined in fpc\rtl\win

function SwitchToThread: BOOL; stdcall; external kernel32 name 'SwitchToThread';

{$endif}



procedure SleepHiRes(ms: cardinal);

begin

  if (ms<>0) or not SwitchToThread then

    Windows.Sleep(ms);

end;



procedure RetrieveSystemInfo;

var

  IsWow64Process: function(Handle: THandle; var Res: BOOL): BOOL; stdcall;

  GetNativeSystemInfo: procedure(var SystemInfo: TSystemInfo); stdcall;

  Res: BOOL;

  Kernel: THandle;

  P: pointer;

  Vers: TWindowsVersion;

begin

  Kernel := GetModuleHandle(kernel32);

  GetTickCount64 := GetProcAddress(Kernel,'GetTickCount64');

  if not Assigned(GetTickCount64) then

    GetTickCount64 := @GetSystemTimeMillisecondsForXP;

  IsWow64Process := GetProcAddress(Kernel,'IsWow64Process');

  Res := false;

  IsWow64 := Assigned(IsWow64Process) and

    IsWow64Process(GetCurrentProcess,Res) and Res;

  FillcharFast(SystemInfo,sizeof(SystemInfo),0);

  if IsWow64 then // see http://msdn.microsoft.com/en-us/library/ms724381(v=VS.85).aspx

    GetNativeSystemInfo := GetProcAddress(Kernel,'GetNativeSystemInfo') else

    @GetNativeSystemInfo := nil;

  if Assigned(GetNativeSystemInfo) then

    GetNativeSystemInfo(SystemInfo) else

    Windows.GetSystemInfo(SystemInfo);

  GetMem(P,10); // ensure that using MIN_PTR_VALUE won't break anything

  if (PtrUInt(P)>MIN_PTR_VALUE) and

     (PtrUInt(SystemInfo.lpMinimumApplicationAddress)<=MIN_PTR_VALUE) then

     PtrUInt(SystemInfo.lpMinimumApplicationAddress) := MIN_PTR_VALUE;

  Freemem(P);

  OSVersionInfo.dwOSVersionInfoSize := sizeof(OSVersionInfo);

  GetVersionEx(OSVersionInfo);

  Vers := wUnknown;

  with OSVersionInfo do

  // see https://msdn.microsoft.com/en-us/library/windows/desktop/ms724833

  case dwMajorVersion of

    5: case dwMinorVersion of

       0: Vers := w2000;

       1: Vers := wXP;

       2: if (wProductType=VER_NT_WORKSTATION) and

             (SystemInfo.wProcessorArchitecture=PROCESSOR_ARCHITECTURE_AMD64) then

            Vers := wXP_64 else

          if GetSystemMetrics(SM_SERVERR2)=0 then

            Vers := wServer2003 else

            Vers := wServer2003_R2;

      end;

    6: case dwMinorVersion of

       0: Vers := wVista;

       1: Vers := wSeven;

       2: Vers := wEight;

       3: Vers := wEightOne;

       4: Vers := wTen;

       end;

    10: Vers := wTen;

  end;

  if Vers>=wVista then begin

    if OSVersionInfo.wProductType<>VER_NT_WORKSTATION then

      inc(Vers,2); // e.g. wEight -> wServer2012

    if SystemInfo.wProcessorArchitecture=PROCESSOR_ARCHITECTURE_AMD64 then

      inc(Vers);   // e.g. wEight -> wEight64

  end;

  OSVersion := Vers;

  with OSVersionInfo do

    if wServicePackMajor=0 then

      FormatUTF8('Windows % (%.%.%)',[WINDOWS_NAME[Vers],

        dwMajorVersion,dwMinorVersion,dwBuildNumber],OSVersionText) else

      FormatUTF8('Windows % SP% (%.%.%)',[WINDOWS_NAME[Vers],wServicePackMajor,

        dwMajorVersion,dwMinorVersion,dwBuildNumber],OSVersionText);

end;



{$else}



procedure RetrieveSystemInfo;

begin

  {$ifdef KYLIX3}

  SystemInfo.nprocs := LibC.get_nprocs;

  uname(SystemInfo.uts);

  {$else}

  FPUname(SystemInfo.uts);

  {$endif}

  with SystemInfo.uts do

    FormatUTF8('%-% %',[sysname,release,version],OSVersionText);

end;



{$ifdef KYLIX3}

function FileOpen(const FileName: string; Mode: LongWord): Integer;

const

  SHAREMODE: array[0..fmShareDenyNone shr 4] of Byte = (

    0,        // No share mode specified

    F_WRLCK,  // fmShareExclusive

    F_RDLCK,  // fmShareDenyWrite

    0);       // fmShareDenyNone

var FileHandle, Tvar: Integer;

    LockVar: TFlock;

    smode: Byte;

begin

  result := -1;

  if FileExists(FileName) and

     ((Mode and 3)<=fmOpenReadWrite) and ((Mode and $F0)<=fmShareDenyNone) then begin

    FileHandle := open64(pointer(FileName),(Mode and 3),FileAccessRights);

    if FileHandle=-1 then

      exit;

    smode := Mode and $F0 shr 4;

    if SHAREMODE[smode]<>0 then begin

      with LockVar do begin

        l_whence := SEEK_SET;

        l_start := 0;

        l_len := 0;

        l_type := SHAREMODE[smode];

      end;

      Tvar := fcntl(FileHandle,F_SETLK,LockVar);

      if Tvar=-1 then begin

        __close(FileHandle);

        exit;

      end;

    end;

    result := FileHandle;

  end;

end;



function GetTickCount64: Int64;

begin

  result := SynKylix.GetTickCount64;

end;



{$endif KYLIX3}



{$ifdef FPC}

function GetTickCount64: Int64;

begin

  result := SynFPCLinux.GetTickCount64;

end;

{$endif}



{$endif MSWINDOWS}



function FileOpenSequentialRead(const FileName: string): Integer;

begin

  {$ifdef MSWINDOWS}

  result := CreateFile(pointer(FileName),GENERIC_READ,

    FILE_SHARE_READ or FILE_SHARE_WRITE,nil, // same as fmShareDenyNone 

    OPEN_EXISTING,FILE_FLAG_SEQUENTIAL_SCAN,0);

  {$else}

  result := FileOpen(FileName,fmOpenRead or fmShareDenyNone);

  {$endif MSWINDOWS}

end;



function FileStreamSequentialRead(const FileName: string): TFileStream;

begin

  {$ifdef DELPHI5ORFPC}

  result := TFileStream.Create(FileName,fmOpenRead or fmShareDenyNone);

  {$else}

  result := TFileStream.Create(FileOpenSequentialRead(FileName));

  {$endif}

end;



function Elapsed(var PreviousTix: Int64; Interval: Integer): Boolean;

var now: Int64;

begin

  if Interval<=0 then

    result := false else begin

    now := GetTickCount64;

    if now-PreviousTix>Interval then begin

      PreviousTix := now;

      result := true;

    end else

      result := false;

  end;

end;



{$ifndef FPC} // FPC has its built-in InterlockedIncrement/InterlockedDecrement

{$ifdef PUREPASCAL}



function InterlockedIncrement(var I: Integer): Integer;

begin

  {$ifdef MSWINDOWS} // AtomicIncrement() may not be available e.g. on Delphi XE2

  result := Windows.InterlockedIncrement(I);

  {$else}

  result := AtomicIncrement(I);

  {$endif}

end;



function InterlockedDecrement(var I: Integer): Integer;

begin

  {$ifdef MSWINDOWS} // AtomicDecrement() may not be available e.g. on Delphi XE2

  result := Windows.InterlockedDecrement(I);

  {$else}

  result := AtomicDecrement(I);

  {$endif}

end;



{$else}



function InterlockedIncrement(var I: Integer): Integer;

asm

     mov  edx,1

     xchg eax,edx

lock xadd [edx],eax

     inc  eax

end;



function InterlockedDecrement(var I: Integer): Integer;

asm

     mov  edx,-1

     xchg eax,edx

lock xadd [edx],eax

     dec  eax

end;



{$endif}

{$endif}



procedure SoundExComputeAnsi(var p: PAnsiChar; var result: cardinal; Values: PSoundExValues);

var n,v,old: cardinal;

begin

  n := 0;

  old := 0;

  if Values<>nil then

  repeat

    {$ifdef USENORMTOUPPER}

    v := NormToUpperByte[ord(p^)]; // also handle 8 bit WinAnsi (1252 accents)

    {$else}

    v := NormToUpperAnsi7Byte[ord(p^)]; // 7 bit char uppercase

    {$endif}

    if not (v in IsWord) then break;

    inc(p);

    dec(v,ord('B'));

    if v>high(TSoundExValues) then continue;

    v := Values[v]; // get soundex value

    if (v=0) or (v=old) then continue; // invalid or dopple value

    old := v;

    result := result shl SOUNDEX_BITS;

    inc(result,v);

    inc(n);

    if n=((32-8)div SOUNDEX_BITS) then // first char use up to 8 bits

      break; // result up to a cardinal size

  until false;

end;



function SoundExComputeFirstCharAnsi(var p: PAnsiChar): cardinal;

label Err;

begin

  if p=nil then begin

Err:result := 0;

    exit;

  end;

  repeat

    {$ifdef USENORMTOUPPER}

    result := NormToUpperByte[ord(p^)]; // also handle 8 bit WinAnsi (CP 1252)

    {$else}

    result := NormToUpperAnsi7Byte[ord(p^)]; // 7 bit char uppercase

    {$endif}

    if result=0 then

      goto Err; // end of input text, without a word

    inc(p);

    // trim initial spaces or 'H'

  until AnsiChar(result) in ['A'..'G','I'..'Z'];

end;



function GetHighUTF8UCS4(var U: PUTF8Char): cardinal;

var extra,i: integer;

    c: cardinal;

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<minimum then

      exit; // invalid input content

  end;

  result := c;

end;



function GetHighUTF8UCS4Inlined(var U: PUTF8Char): cardinal;

  {$ifdef HASINLINE}inline;{$endif}

var extra,i: integer;

    c: cardinal;

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<minimum then

      exit; // invalid input content

  end;

  result := c;

end;



function GetNextUTF8Upper(var U: PUTF8Char): cardinal;

begin

  result := ord(U^);

  if result=0 then

    exit;

  if result and $80=0 then begin

    inc(U);

    {$ifdef USENORMTOUPPER}

    result := NormToUpperByte[result];

    {$else}

    result := NormToUpperAnsi7Byte[result];

    {$endif}

    exit;

  end;

  result := GetHighUTF8UCS4(U);

  if (result<=255) and (WinAnsiConvert.AnsiToWide[result]<=255) then

    {$ifdef USENORMTOUPPER}

    result := NormToUpperByte[result];

    {$else}

    result := NormToUpperAnsi7Byte[result];

    {$endif}

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 (v in IsWord) then break;

    dec(v,ord('B'));

    if v>high(TSoundExValues) then continue;

    v := Values[v]; // get soundex value

    if (v=0) or (v=old) then continue; // invalid or dopple value

    old := v;

    result := result shl SOUNDEX_BITS;

    inc(result,v);

    inc(n);

    if n=((32-8)div SOUNDEX_BITS) then // first char use up to 8 bits

      break; // result up to a cardinal size

  until false;

end;



function SoundExComputeFirstCharUTF8(var U: PUTF8Char): cardinal;

label Err;

begin

  if U=nil then begin

Err:result := 0;

    exit;

  end;

  repeat

    result := GetNextUTF8Upper(U);

    if result=0 then

      goto Err; // end of input text, without a word

    // trim initial spaces or 'H'

  until AnsiChar(result) in ['A'..'G','I'..'Z'];

end;



function FindNextUTF8WordBegin(U: PUTF8Char): PUTF8Char;

var c: cardinal;

    V: PUTF8Char;

begin

  result := nil;

  repeat

    c := GetNextUTF8Upper(U);

    if c=0 then

      exit;

  until not(c in IsWord);

  repeat

    V := U;

    c := GetNextUTF8Upper(U);

    if c=0 then

      exit;

  until c in IsWord;

  result := V;

end;





{ TSynSoundEx }



const

  /// english Soundex pronunciation scores

  // - defines the default values used for the SoundEx() function below

  // (used if Values parameter is nil)

  ValueEnglish: TSoundExValues =

  // B C D E F G H I J K L M N O P Q R S T U V W X Y Z

    (1,2,3,0,1,2,0,0,2,2,4,5,5,0,1,2,6,2,3,0,1,0,2,0,2);



  /// french Soundex pronunciation scores

  // - can be used to override default values used for the SoundEx()

  // function below

  ValueFrench: TSoundExValues =

  // B C D E F G H I J K L M N O P Q R S T U V W X Y Z

    (1,2,3,0,9,7,0,0,7,2,4,5,5,0,1,2,6,8,3,0,9,0,8,0,8);



  /// spanish Soundex pronunciation scores

  // - can be used to override default values used for the SoundEx()

  // function below

  ValueSpanish: TSoundExValues =

  // B C D E F G H I J K L M N O P Q R S T U V W X Y Z

    (1,2,3,0,1,2,0,0,0,2,0,5,5,0,1,2,6,2,3,0,1,0,2,0,2);



  SOUNDEXVALUES: array[TSynSoundExPronunciation] of PSoundExValues =

    (@ValueEnglish,@ValueFrench,@ValueSpanish,@ValueEnglish);



function TSynSoundEx.Ansi(A: PAnsiChar): boolean;

var Value, c: cardinal;

begin

  result := false;

  if A=nil then exit;

  repeat

    // test beginning of word

    c := SoundExComputeFirstCharAnsi(A);

    if c=0 then exit else

    if c=FirstChar then begin

      // here we had the first char match -> check if word match UpperValue

      Value := c-(ord('A')-1);

      SoundExComputeAnsi(A,Value,fValues);

      if Value=search then begin

        result := true; // UpperValue found!

        exit;

      end;

    end else

    repeat

      if A^=#0 then exit else

{$ifdef USENORMTOUPPER}

        if not(NormToUpperByte[ord(A^)] in IsWord) then break else inc(A);

{$else} if not(ord(A^) in IsWord) then break else inc(A); {$endif}

    until false;

    // find beginning of next word

    repeat

      if A^=#0 then exit else

{$ifdef USENORMTOUPPER}

        if NormToUpperByte[ord(A^)] in IsWord then break else inc(A);

{$else} if ord(A^) in IsWord then break else inc(A); {$endif}

    until false;

  until false;

end;



function TSynSoundEx.UTF8(U: PUTF8Char): boolean;

var Value, c: cardinal;

    V: PUTF8Char;

begin

  result := false;

  if U=nil then exit;

  repeat

    // find beginning of word

    c := SoundExComputeFirstCharUTF8(U);

    if c=0 then exit else

    if c=FirstChar then begin

      // here we had the first char match -> check if word match UpperValue

      Value := c-(ord('A')-1);

      SoundExComputeUTF8(U,Value,fValues);

      if Value=search then begin

        result := true; // UpperValue found!

        exit;

      end;

    end else

    repeat

      c := GetNextUTF8Upper(U);

      if c=0 then

        exit;

    until not(c in IsWord);

    // find beginning of next word

    repeat

      if U=nil then exit;

      V := U;

      c := GetNextUTF8Upper(U);

      if c=0 then

        exit;

    until c in IsWord;

    U := V;

  until U=nil;

end;



function TSynSoundEx.Prepare(UpperValue: PAnsiChar; Lang: TSynSoundExPronunciation): boolean;

begin

  fValues := SOUNDEXVALUES[Lang];

  Search := SoundExAnsi(UpperValue,nil,Lang);

  if Search=0 then

    result := false else begin

    FirstChar := SoundExComputeFirstCharAnsi(UpperValue);

    result := true;

  end;

end;



function SoundExAnsi(A: PAnsiChar; next: PPAnsiChar;

  Lang: TSynSoundExPronunciation): cardinal;

begin

  result := SoundExComputeFirstCharAnsi(A);

  if result<>0 then begin

    dec(result,ord('A')-1);   // first Soundex char is first char

    SoundExComputeAnsi(A,result,SOUNDEXVALUES[Lang]);

  end;

  if next<>nil then begin

    {$ifdef USENORMTOUPPER}

    while NormToUpperByte[ord(A^)] in IsWord do inc(A); // go to end of word

    {$else}

    while ord(A^) in IsWord do inc(A); // go to end of word

    {$endif}

    next^ := A;

  end;

end;



function SoundExUTF8(U: PUTF8Char; next: PPUTF8Char;

  Lang: TSynSoundExPronunciation): cardinal;

begin

  result := SoundExComputeFirstCharUTF8(U);

  if result<>0 then begin

    dec(result,ord('A')-1);   // first Soundex char is first char

    SoundExComputeUTF8(U,result,SOUNDEXVALUES[Lang]);

  end;

  if next<>nil then

    next^ := FindNextUTF8WordBegin(U);

end;



{$ifdef USENORMTOUPPER}



function AnsiICompW(u1, u2: PWideChar): PtrInt;

begin

  if u1<>u2 then

    if u1<>nil then

      if u2<>nil then

        repeat

          result := PtrInt(u1^)-PtrInt(u2^);

          if result<>0 then begin

            if (PtrInt(u1^)>255) or (PtrInt(u2^)>255) then exit;

            result := NormToUpperAnsi7Byte[PtrInt(u1^)]-NormToUpperAnsi7Byte[PtrInt(u2^)];

            if result<>0 then exit;

          end;

          if (u1^=#0) or (u2^=#0) then break;

          inc(u1);

          inc(u2);

        until false else

        result := 1 else  // u2=''

      result := -1 else // u1=''

    result := 0;      // u1=u2

end;





{$ifdef PUREPASCAL}

function AnsiIComp(Str1, Str2: PWinAnsiChar): PtrInt;

begin

  if Str1<>Str2 then

  if Str1<>nil then

  if Str2<>nil then

  repeat

    result := NormToUpperByte[ord(Str1^)]-NormToUpperByte[pByte(Str2)^];

    if result<>0 then exit;

    if (Str1^=#0) or (Str2^=#0) then break;

    inc(Str1);

    inc(Str2);

  until false else

  result := 1 else  // Str2=''

  result := -1 else // Str1=''

  result := 0;      // Str1=Str2

end;

{$else}

function AnsiIComp(Str1, Str2: PWinAnsiChar): PtrInt;

asm // fast 8 bits WinAnsi comparaison using the NormToUpper[] array

    cmp eax,edx

    je @2

    test eax,edx // is either of the strings perhaps nil?

    jz @3

@0: push ebx // compare the first character (faster quicksort)

    movzx ebx,byte ptr [eax] // ebx=S1[1]

    movzx ecx,byte ptr [edx] // ecx=S2[1]

    test ebx,ebx

    jz @z

    cmp ebx,ecx

    je @s

    mov bl,byte ptr [NormToUpper+ebx]

    mov cl,byte ptr [NormToUpper+ecx]

    cmp ebx,ecx

    je @s

    mov eax,ebx

    pop ebx

    sub eax,ecx // return S1[1]-S2[1]

    ret

@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?

    pop ebx

    jz @2

@4: or eax,-1 // return -1 (S1<S2)

end;

{$endif}



function ConvertCaseUTF8(P: PUTF8Char; const Table: TNormTableByte): PtrInt;

var D,S: PUTF8Char;

    c: PtrUInt;

    extra,i: integer;

begin

  result := 0;

  if P=nil then

    exit;

  D := P;

  repeat

    c := byte(P[0]);

    inc(P);

    if c=0 then

      break;

    if c and $80=0 then begin

      D[result] := AnsiChar(Table[c]);

      inc(result);

    end else begin

      extra := UTF8_EXTRABYTES[c];

      if extra=0 then exit else // invalid leading byte

      for i := 0 to extra-1 do

        if byte(P[i]) and $c0<>$80 then

          exit else // invalid input content

          c := c shl 6+byte(P[i]);

      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);

      MoveFast(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);

  SetString(result,PAnsiChar(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);

  SetString(result,PAnsiChar(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;

    b: byte;

begin // fast UTF-8 comparaison using the NormToUpper[] array for all 8 bits values

  if u1<>u2 then

  if u1<>nil then

  if u2<>nil then

  repeat

    result := ord(u1^);

    if result and $80=0 then

      if result<>0 then begin

        result := NormToUpperByte[result];

        inc(u1);

        b := ord(u2^);

        if b and $80=0 then begin

          if b=0 then exit; // u1>u2 -> return u1^

          dec(result,NormToUpperByte[b]);

          inc(u2);

          if result<>0 then exit;

          continue;

        end;

      end else begin // u1^=#0 -> end of u1 reached

        if u2^<>#0 then    // end of u2 reached -> u1=u2 -> return 0

          result := -1;    // u1<u2

        exit;

      end else begin

        result := GetHighUTF8UCS4Inlined(u1);

        if result and $ffffff00=0 then

          result := NormToUpperByte[result]; // 8 bits to upper, 32 bits as is

      end;

    c2 := ord(u2^);

    if c2 and $80=0 then begin

      inc(u2);

      if c2=0 then exit; // u1>u2 -> return u1^

      dec(result,NormToUpperByte[c2]);

      if result<>0 then exit;

    end else begin

      c2 := GetHighUTF8UCS4Inlined(u2);

      if c2 and $ffffff00=0 then

        dec(result,NormToUpperByte[c2]) else // 8 bits to upper

        dec(result,c2); // 32 bits 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;

label neg,pos,eq;

begin // fast UTF-8 comparaison using the NormToUpper[] array for all 8 bits values

  if u1<>u2 then

  if (u1<>nil) and (L1<>0) then

  if (u2<>nil) and (L2<>0) then

  repeat

    result := pByte(u1)^;

    inc(u1);

    dec(L1);

    if result and $80=0 then begin

      result := NormToUpperByte[result];

      if pByte(u2)^ and $80=0 then begin

        dec(result,NormToUpperByte[pByte(u2)^]);

        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<u2

            exit;         // L1=0 and L2=0 -> 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 := NormToUpperByte[result]; // 8 bits to upper, 32 bits as is

    end;

    // here result=NormToUpper[u1^]

    c2 := pByte(u2)^;

    inc(u2);

    dec(L2);

    if c2 and $80=0 then begin

      dec(result,NormToUpperByte[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,NormToUpperByte[c2]) else // 8 bits to upper

        dec(result,c2); // returns 32 bits 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 // u1<u2

    if L2=0 then goto pos;  // u1>u2

  until false else

pos: result := 1 else  // u2='' or u1>u2

neg: result := -1 else // u1='' or u1<u2

     result := 0;      // u1=u2

end;



function SameTextU(const S1, S2: RawUTF8): Boolean;

// checking UTF-8 lengths is not accurate: surrogates may be confusing

begin

  result := UTF8IComp(pointer(S1),pointer(S2))=0;

end;



{$else} // no NormToUpper[]



function AnsiIComp(Str1, Str2: PWinAnsiChar): integer;

{$ifdef PUREPASCAL}

begin

  result := StrIComp(Str1,Str2); // fast enough

end;

{$else}

asm

  jmp StrIComp // LVCL without NormToUpper[]: use default SysUtils implementation

end;

{$endif}

{$endif}



function FindAnsi(A, UpperValue: PAnsiChar): boolean;

var ValueStart: PAnsiChar;

{$ifndef USENORMTOUPPER}

    ch: AnsiChar;

{$endif}

begin

  result := false;

  if (A=nil) or (UpperValue=nil) then exit;

  ValueStart := UpperValue;

  repeat

    // test beginning of word

    repeat

      if A^=#0 then exit else

{$ifdef USENORMTOUPPER}

      if byte(NormToUpper[A^]) in IsWord then break else inc(A);  {$else}

      if byte(NormToUpperAnsi7[A^]) in IsWord then break else inc(A);

{$endif}

    until false;

    // check if this word is the UpperValue

    UpperValue := ValueStart;

    repeat

{$ifdef USENORMTOUPPER}

      if NormToUpper[A^]<>UpperValue^ then break;  {$else}

      if NormToUpperAnsi7[A^]<>UpperValue^ then break;

{$endif}

      inc(UpperValue);

      if UpperValue^=#0 then begin

        result := true; // UpperValue found!

        exit;

      end;

      inc(A);

      if A^=#0 then exit;

    until false;

    // find beginning of next word

    repeat

      if A^=#0 then exit else

{$ifdef USENORMTOUPPER}

        if not (NormToUpperByte[ord(A^)] in IsWord) then break else inc(A);

{$else} if not (ord(A^) in IsWord) then break else inc(A); {$endif}

    until false;

  until false;

end;



function FindUnicode(PW, Upper: PWideChar; UpperLen: integer): boolean;

var Start: PWideChar;

begin

  result := false;

  if (PW=nil) or (Upper=nil) then exit;

  repeat

    // go to beginning of next word

    repeat

      if ord(PW^)=0 then exit else

      if (ord(PW^)>126) or (ord(PW^) in IsWord) then

        Break;

      inc(PW);

    until false;

    Start := PW;

    // search end of word matching UpperLen characters

    repeat

      inc(PW);

    until (PW-Start>=UpperLen) or

      (ord(PW^)=0) or ((ord(PW^)<126) and (not(ord(PW^) in IsWord)));

    if PW-Start>=UpperLen then

      if CompareStringW(LOCALE_USER_DEFAULT,NORM_IGNORECASE,Start,UpperLen,Upper,UpperLen)=2 then begin

        result := true; // match found

        exit;

      end;

    // not found: go to end of current word

    repeat

      if PW^=#0 then exit else

      if ((ord(PW^)<126) and (not(ord(PW^) in IsWord))) then Break;

      inc(PW);

    until false;

  until false;

end;



function FindUTF8(U: PUTF8Char; UpperValue: PAnsiChar): boolean;

var ValueStart: PAnsiChar;

{$ifdef USENORMTOUPPER}

    c: cardinal;

    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 and $80=0 then begin

        if c in IsWord then

          if PAnsiChar(@NormToUpper)[c]<>FirstChar then

            goto Next else

            break;

      end else

      if c and $20=0 then begin // fast direct process $0..$7ff

        c := c shl 6+byte(U^)-$3080;

        inc(U);

        if c<=255 then begin

          c := NormToUpperByte[c];

          if c in IsWord then

            if AnsiChar(c)<>FirstChar then

              goto Next else

              break;

        end;

      end else

        if UTF8_EXTRABYTES[c]=0 then

          exit else // invalid leading byte

          inc(U,UTF8_EXTRABYTES[c]); // just ignore surrogates for soundex

    until false;

    // here we had the first char match -> check if this word match UpperValue

    UpperValue := ValueStart;

    repeat

      if UpperValue^=#0 then begin

        result := true; // UpperValue found!

        exit;

      end;

      c := byte(U^); inc(U); // next chars

      if c=0 then exit else

      if c and $80=0 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;

    // find beginning of next word

Next:

{$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^) and $80=0 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;

{$endif}

    // find beginning of next word

    U := FindNextUTF8WordBegin(U);

  until U=nil;

end;



function HexDisplayToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: integer): boolean;

var B,C: byte;

    i: integer;

begin

  result := false; // return false if any invalid char

  if (Hex=nil) or (Bin=nil) then

    exit;

  inc(Bin,BinBytes-1);

  for i := 1 to BinBytes do begin

    B := ConvertHexToBin[Ord(Hex^)];

    inc(Hex);

    if B>15 then exit;

    C := ConvertHexToBin[Ord(Hex^)];

    Inc(Hex);

    if C>15 then exit;

    Bin^ := B shl 4+C;

    Dec(Bin);

  end;

  result := true; // correct content in Hex

end;



function HexDisplayToCardinal(Hex: PAnsiChar; out aValue: cardinal): boolean;

begin

  result := HexDisplayToBin(Hex,@aValue,sizeof(aValue));

end;



function HexDisplayToInt64(Hex: PAnsiChar; out aValue: Int64): boolean;

begin

  result := HexDisplayToBin(Hex,@aValue,sizeof(aValue));

end;



function HexDisplayToInt64(const Hex: RawByteString): Int64;

begin

  if not HexDisplayToBin(pointer(Hex),@result,sizeof(result)) then

    result := 0;

end;



function HexToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: Integer): boolean;

var I: Integer;

    B,C: byte;

begin

  result := false; // return false if any invalid char

  if Hex=nil then

    exit;

  if Bin<>nil then

  for I := 1 to BinBytes do begin

    B := ConvertHexToBin[Ord(Hex^)];

    inc(Hex);

    if B>15 then exit;

    C := ConvertHexToBin[Ord(Hex^)];

    Inc(Hex);

    if C>15 then exit;

    Bin^ := B shl 4+C;

    Inc(Bin);

  end else

  for I := 1 to BinBytes do begin // no Bin^ -> just validate Hex^ Stream format

    B := ConvertHexToBin[Ord(Hex^)];

    inc(Hex);

    if B>15 then exit;

    C := ConvertHexToBin[Ord(Hex^)];

    Inc(Hex);

    if C>15 then exit;

  end;

  result := true; // conversion OK

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: byte;

begin

  if Hex<>nil then begin

    B := ConvertHexToBin[Ord(Hex[0])];

    if B<=15 then begin

      C := ConvertHexToBin[Ord(Hex[1])];

      if C<=15 then begin

        if Bin<>nil then

          Bin^ := AnsiChar(B shl 4+C);

        result := true;

        exit;

      end;

    end;

  end;

  result := false; // return false if any invalid char

end;



function HexToWideChar(Hex: PAnsiChar): cardinal;

var B: cardinal;

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;



const

  b64: array[0..63] of AnsiChar =

    'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';



function Base64EncodeMain(rp, sp: PAnsiChar; len: cardinal): integer;

{$ifdef PUREPASCAL}

  {$ifdef HASINLINE}inline;{$endif}

var i: integer;

    c: cardinal;

begin

  result := len div 3;

  for i := 1 to result do begin

    c := ord(sp[0]) shl 16 + ord(sp[1]) shl 8 + ord(sp[2]);

    rp[0] := b64[(c shr 18) and $3f];

    rp[1] := b64[(c shr 12) and $3f];

    rp[2] := b64[(c shr 6) and $3f];

    rp[3] := b64[c and $3f];

    inc(rp,4);

    inc(sp,3);

  end;

end;

{$else}

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 b64

    mov ebp,eax

    push eax

    jz @z

    // edi=b64 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]

    lea ebx,[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

    dec ebp

    mov [esi],ecx

    lea esi,[esi+4]

    jnz @1

@z: pop eax // result := len div 3

    pop ebp

    pop edi

    pop esi

    pop ebx

end;



{$endif}



procedure Base64EncodeTrailing(rp, sp: PAnsiChar; len: cardinal);

  {$ifdef HASINLINE}inline;{$endif}

var c: cardinal;

begin

  case len of

    1: begin

      c := ord(sp[0]) shl 4;

      rp[0] := b64[(c shr 6) and $3f];

      rp[1] := b64[c and $3f];

      rp[2] := '=';

      rp[3] := '=';

    end;

    2: begin

      c := ord(sp[0]) shl 10 + ord(sp[1]) shl 2;

      rp[0] := b64[(c shr 12) and $3f];

      rp[1] := b64[(c shr 6) and $3f];

      rp[2] := b64[c and $3f];

      rp[3] := '=';

    end;

  end;

end;



procedure Base64Encode(rp, sp: PAnsiChar; len: cardinal);

var main: cardinal;

begin

  main := Base64EncodeMain(rp,sp,len);

  Base64EncodeTrailing(rp+main*4,sp+main*3,len-main*3);

end;



function BinToBase64Length(len: PtrUInt): PtrUInt;

begin

  result := ((len+2)div 3)*4;

end;



function BinToBase64(const s: RawByteString): RawUTF8;

var len: integer;

begin

  result := '';

  len := length(s);

  if len=0 then

    exit;

  SetLength(result,BinToBase64Length(len));

  Base64Encode(pointer(result),pointer(s),len);

end;



function BinToBase64(Bin: PAnsiChar; BinBytes: integer): RawUTF8;

begin

  result := '';

  if BinBytes=0 then

    exit;

  SetLength(result,BinToBase64Length(BinBytes));

  Base64Encode(pointer(result),Bin,BinBytes);

end;



procedure Base64ToURI(var base64: RawUTF8);

var P: PUTF8Char;

begin

  {$ifdef FPC}

  UniqueString(base64); // @base64[1] won't call UniqueString() under FPC :(

  {$endif}

  P := @base64[1];

  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;



procedure Base64FromURI(var base64: RawUTF8);

var P: PUTF8Char;

    len,i,append: integer;

begin

  len := length(base64);

  if len=0 then

    exit;

  {$ifdef FPC}

  UniqueString(base64); // @base64[1] won't call UniqueString() under FPC :(

  {$endif}

  P := @base64[1];

  repeat

    case P^ of

    #0: break;

    '-': P^ := '+';

    '_': P^ := '/';

    end;

    inc(P);

  until false;

  append := 4-(len and 3);

  if append<>4 then begin // add unsignificant trailing '=' characters

    SetLength(base64,len+append);

    for i := len+1 to len+append do

      base64[i] := '=';

  end;

end;



function BinToBase64URI(Bin: PAnsiChar; BinBytes: integer): RawUTF8;

begin

  result := BinToBase64(Bin,BinBytes);

  Base64ToURI(result);

end;



function BinToBase64WithMagic(const s: RawByteString): RawUTF8;

var len: integer;

begin

  result:='';

  len := length(s);

  if len=0 then

    exit;

  SetLength(result,((len+2) div 3)*4+3);

  PInteger(pointer(result))^ := JSON_BASE64_MAGIC;

  Base64Encode(PAnsiChar(pointer(result))+3,pointer(s),len);

end;



function BinToBase64WithMagic(Data: pointer; DataLen: integer): RawUTF8; overload;

begin

  result:='';

  if DataLen<=0 then

    exit;

  SetLength(result,((DataLen+2) div 3)*4+3);

  PInteger(pointer(result))^ := JSON_BASE64_MAGIC;

  Base64Encode(PAnsiChar(pointer(result))+3,Data,DataLen);

end;



var

  /// a conversion table from Base64 text into binary data

  // - used by Base64ToBin/IsBase64 functions

  ConvertBase64ToBin: array[AnsiChar] of shortint;



function IsBase64(sp: PAnsiChar; len: PtrInt): boolean;

var i: PtrInt;

begin

  result := false;

  if (len=0) or (len and 3<>0) then

    exit;

  for i := 0 to len-5 do

    if ConvertBase64ToBin[sp[i]]<0 then

      exit;

  inc(sp,len-4);

  if (ConvertBase64ToBin[sp[0]]=-1) or // -2 = '=' is allowed here

     (ConvertBase64ToBin[sp[1]]=-1) or (ConvertBase64ToBin[sp[2]]=-1) or (ConvertBase64ToBin[sp[3]]=-1) then

      exit;

  result := true; // layout seems correct

end;



function IsBase64(const s: RawByteString): boolean;

begin

  result := IsBase64(pointer(s),length(s));

end;



function Base64ToBinLength(sp: PAnsiChar; len: PtrInt): PtrInt;

begin

  if (len=0) or (len and 3<>0) then begin

    result := 0;

    exit;

  end;

  if ConvertBase64ToBin[sp[len-2]]>=0 then

    if ConvertBase64ToBin[sp[len-1]]>=0 then

      result := 0 else

      result := 1 else

      result := 2;

  result := (len shr 2)*3-result;

end;



procedure Base64Decode(sp,rp: PAnsiChar; len: PtrInt);

{$ifdef PUREPASCAL}

var i: PtrInt;

    c, ch: PtrInt;

begin

  for i := 1 to len do begin

    c := ConvertBase64ToBin[sp[0]];

    if c>=0 then begin

      c := c shl 6;

      ch := ConvertBase64ToBin[sp[1]];

      if ch>=0 then begin

        c := (c or ch) shl 6;

        ch := ConvertBase64ToBin[sp[2]];

        if ch>=0 then begin

          c := (c or ch) shl 6;

          ch := ConvertBase64ToBin[sp[3]];

          if ch>=0 then begin

            c := c or ch;

            rp[2] := AnsiChar(c);

            c := c shr 8;

            rp[1] := AnsiChar(c);

            c := c shr 8;

            rp[0] := AnsiChar(c);

            inc(rp,3);

            inc(sp,4);

            continue;

          end else begin

            c := c shr 8;

            rp[1] := AnsiChar(c);

            rp[0] := AnsiChar(c shr 8);

            //assert(resultlen=len*3-1);

            exit;

          end;

        end;

      end;

    end;

    rp[0] := AnsiChar(c shr 10);

    //assert(resultlen=len*3-2);

    exit;

  end;

end;

{$else}

asm // eax=sp edx=rp ecx=len - pipeline optimized version by AB

     push ebx

     push esi

     push edi

     push ebp

     push eax

     test ecx,ecx

     mov ebp,edx

     lea edi,[ConvertBase64ToBin]

     mov [esp],ecx

     jz @4

@0:  movzx edx,byte ptr [eax]

     movzx ebx,byte ptr [eax+$01]

     movsx ecx,byte ptr [edi+edx]

     movsx esi,byte ptr [edi+ebx]

     test ecx,ecx

     jl @1

     shl ecx,$06

     test esi,esi

     jl @1

     or ecx,esi

     movzx edx,byte ptr [eax+$02]

     movzx ebx,byte ptr [eax+$03]

     shl ecx,$06

     movsx esi,byte ptr [edi+edx]

     movsx edx,byte ptr [edi+ebx]

     test esi,esi

     jl @1

     or ecx,esi

     shl ecx,$06

     test edx,edx

     jl @2

     or ecx,edx

     lea eax,[eax+4]

     mov [ebp+2],cl

     mov [ebp+1],ch

     shr ecx,16

     dec dword ptr [esp]

     mov [ebp],cl

     lea ebp,[ebp+3]

     jnz @0

@4:  pop eax

     pop ebp

     pop edi

     pop esi

     pop ebx

     ret

@2:  shr ecx,$08

     mov [ebp+$01],cl

     mov [ebp],ch

     jmp @4

@1:  shr ecx,$0a

     mov [ebp],cl

     jmp @4

end;

{$endif}



function Base64ToBin(const s: RawByteString): RawByteString;

var len, resultLen: PtrInt;

begin

  len := length(s);

  resultLen := Base64ToBinLength(pointer(s),len);

  if resultLen=0 then

    result := '' else begin

    SetString(result,nil,resultLen);

    Base64Decode(pointer(s),pointer(result),len shr 2);

  end;

end;



function Base64ToBin(sp: PAnsiChar; len: PtrInt): RawByteString;

begin

  Base64ToBin(sp,len,result);

end;



procedure Base64ToBin(sp: PAnsiChar; len: PtrInt; var result: RawByteString);

var resultLen: PtrInt;

begin

  resultLen := Base64ToBinLength(sp,len);

  if resultLen=0 then

    result := '' else begin

    SetString(result,nil,resultLen);

    Base64Decode(sp,pointer(result),len shr 2);

  end;

end;



procedure Base64ToBin(sp: PAnsiChar; len: PtrInt; var result: TSynTempBuffer); overload;

var resultLen: PtrInt;

begin

  resultLen := Base64ToBinLength(sp,len);

  if resultLen=0 then

    result.Init(0) else begin

    result.Init(resultLen);

    Base64Decode(sp,result.buf,len shr 2);

  end;

end;



function Base64ToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt;

  nofullcheck: boolean): boolean;

begin

  result := (bin<>nil) and (Base64ToBinLength(base64,base64len)=binlen) and

     (nofullcheck or IsBase64(base64,base64len));

  if result then

    Base64Decode(base64,bin,base64len shr 2);

end;





function BinToSource(const ConstName, Comment: RawUTF8;

  Data: pointer; Len, PerLine: integer; const Suffix: RawUTF8): RawUTF8;

var W: TTextWriter;

begin

  if (Data=nil) or (Len<=0) or (PerLine<=0) then

    result := '' else begin

    W := TTextWriter.CreateOwnedStream(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'  // %',[Comment]);

  Dest.Add(#13'  %: 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'  %_LEN = SizeOf(%);'#13,[ConstName,ConstName]);

end;





function DateToSQL(Date: TDateTime): RawUTF8;

begin

  if Date<=0 then

    result := '' else begin

    SetLength(result,13);

    PCardinal(pointer(result))^ := JSON_SQLDATE_MAGIC;

    DateToIso8601PChar(Date,PUTF8Char(pointer(result))+3,True);

  end;

end;



function DateToSQL(Year,Month,Day: Cardinal): RawUTF8; overload;

begin

  if (Year=0) or (Month-1>11) or (Day-1>30) then

    result := '' else begin

    SetLength(result,13);

    PCardinal(pointer(result))^ := JSON_SQLDATE_MAGIC;

    DateToIso8601PChar(PUTF8Char(pointer(result))+3,True,Year,Month,Day);

  end;

end;



function DateTimeToSQL(DT: TDateTime): RawUTF8;

begin

  if DT<=0 then

    result := '' else begin

    SetLength(result,3);

    PCardinal(pointer(result))^ := JSON_SQLDATE_MAGIC;

    if frac(DT)=0 then

      result := result+DateToIso8601(DT,true) else

    if trunc(DT)=0 then

      result := result+TimeToIso8601(DT,true,'T') else

      result := result+DateTimeToIso8601(DT,true,'T');

  end;

end;



function TimeLogToSQL(const TimeStamp: TTimeLog): RawUTF8;

begin

  if TimeStamp=0 then

    result := '' else begin

    SetLength(result,3);

    PCardinal(pointer(result))^ := JSON_SQLDATE_MAGIC;

    result := result+PTimeLogBits(@TimeStamp)^.Text(true);

  end;

end;



function SQLToDateTime(const ParamValueWithMagic: RawUTF8): TDateTime;

begin

  result := Iso8601ToDateTimePUTF8Char(PUTF8Char(pointer(ParamValueWithMagic))+3,

    length(ParamValueWithMagic)-3);

end;



function UpperCaseUnicode(const S: RawUTF8): RawUTF8;

{$ifdef MSWINDOWS}

var tmp: RawUnicode;

    TmpLen: integer;

{$endif}

begin

{$ifdef MSWINDOWS}

  tmp := Utf8DecodeToRawUnicodeUI(S,@TmpLen);

  TmpLen := TmpLen shr 1;

  CharUpperBuffW(pointer(tmp),TmpLen);

  RawUnicodeToUtf8(pointer(tmp),TmpLen,result);

{$endif}

{$ifdef POSIX}

  result := WideStringToUTF8(WideUpperCase(UTF8ToWideString(S)));

{$endif}

end;



function LowerCaseUnicode(const S: RawUTF8): RawUTF8;

{$ifdef MSWINDOWS}

var tmp: RawUnicode;

    TmpLen: integer;

{$endif}

begin

{$ifdef MSWINDOWS}

  tmp := Utf8DecodeToRawUnicodeUI(S,@TmpLen);

  TmpLen := TmpLen shr 1;

  CharLowerBuffW(pointer(tmp),TmpLen);

  RawUnicodeToUtf8(pointer(tmp),TmpLen,result);

{$endif}

{$ifdef POSIX}

  result := WideStringToUTF8(WideLowerCase(UTF8ToWideString(S)));

{$endif}

end;



function UpperCase(const S: RawUTF8): RawUTF8;

var L, i: PtrInt;

begin

  L := length(S);

  SetString(Result,PAnsiChar(pointer(S)),L);

  for i := 0 to L-1 do

    if PByteArray(result)[i] in [ord('a')..ord('z')] then

      dec(PByteArray(result)[i],32);

end;



procedure UpperCaseCopy(Text: PUTF8Char; Len: integer; var result: RawUTF8);

var i: integer;

begin

  SetRawUTF8(result,PAnsiChar(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);

  SetRawUTF8(Dest,PAnsiChar(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;



function LowerCase(const S: RawUTF8): RawUTF8;

var L, i: PtrInt;

begin

  L := length(S);

  SetString(result,PAnsiChar(pointer(S)),L);

  for i := 0 to L-1 do

    if PByteArray(result)[i] in [ord('A')..ord('Z')] then

      inc(PByteArray(result)[i],32);

end;



procedure LowerCaseCopy(Text: PUTF8Char; Len: integer; var result: RawUTF8);

var i: integer;

begin

  SetRawUTF8(result,PAnsiChar(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;



function TrimLeft(const S: RawUTF8): RawUTF8;

var i, l: Integer;

begin

  l := Length(S);

  i := 1;

  while (i <= l) and (S[i] <= ' ') do

    Inc(i);

  Result := Copy(S, i, Maxint);

end;



function TrimRight(const S: RawUTF8): RawUTF8;

var i: Integer;

begin

  i := Length(S);

  while (i > 0) and (S[i] <= ' ') do

    Dec(i);

  SetString(result,PAnsiChar(pointer(S)),i);

end;



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: array[AnsiChar] of word absolute TwoDigitsHex;

  TwoDigitsHexWB: array[byte] of word absolute TwoDigitsHex;



procedure BinToHex(Bin, Hex: PAnsiChar; BinBytes: integer);

var j: cardinal;

begin

  for j := 1 to BinBytes do begin

    PWord(Hex)^ := TwoDigitsHexW[Bin^];

    inc(Hex,2);

    inc(Bin);

  end;

end;



function BinToHex(const Bin: RawByteString): RawUTF8; overload;

var L: integer;

begin

  L := length(Bin);

  FastNewRawUTF8(result,L*2);

  SynCommons.BinToHex(pointer(Bin),pointer(Result),L);

end;



function BinToHex(Bin: PAnsiChar; BinBytes: integer): RawUTF8;

begin

  FastNewRawUTF8(result,BinBytes*2);

  SynCommons.BinToHex(Bin,pointer(Result),BinBytes);

end;



function HexToBin(const Hex: RawUTF8): RawByteString; overload;

var L: integer;

begin

  L := length(Hex);

  if L and 1<>0 then

    L := 0 else // hexadecimal should be in char pairs

    L := L shr 1;

  SetLength(result,L);

  if not SynCommons.HexToBin(pointer(Hex),pointer(result),L) then

    result := '';

end;



procedure BinToHexDisplay(Bin, Hex: PAnsiChar; BinBytes: integer);

var j: integer;

begin

  for j := BinBytes-1 downto 0 do begin

    PWord(Hex+j*2)^ := TwoDigitsHexW[Bin^];

    inc(Bin);

  end;

end;



function BinToHexDisplay(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload;

begin

  FastNewRawUTF8(result,BinBytes*2);

  BinToHexDisplay(Bin,pointer(result),BinBytes);

end;



procedure PointerToHex(aPointer: Pointer; var result: RawUTF8);

begin

  FastNewRawUTF8(result,sizeof(Pointer)*2);

  BinToHexDisplay(aPointer,pointer(result),sizeof(Pointer));

end;



function PointerToHex(aPointer: Pointer): RawUTF8;

begin

  FastNewRawUTF8(result,sizeof(Pointer)*2);

  BinToHexDisplay(aPointer,pointer(result),sizeof(Pointer));

end;



function CardinalToHex(aCardinal: Cardinal): RawUTF8;

begin

  FastNewRawUTF8(result,sizeof(Cardinal)*2);

  BinToHexDisplay(@aCardinal,pointer(result),sizeof(Cardinal));

end;



function Int64ToHex(aInt64: Int64): RawUTF8;

begin

  FastNewRawUTF8(result,sizeof(Int64)*2);

  BinToHexDisplay(@AInt64,pointer(result),sizeof(Int64));

end;



procedure Int64ToHex(aInt64: Int64; var result: RawUTF8);

begin

  FastNewRawUTF8(result,sizeof(Int64)*2);

  BinToHexDisplay(@AInt64,pointer(result),sizeof(Int64));

end;



type TWordRec = packed record YDiv100, YMod100: byte; end;



{$ifdef FPC_OR_PUREPASCAL} // Alf reported asm below fails with FPC/Linux32

function Div100(Y: word): TWordRec; {$ifdef HASINLINE}inline;{$endif}

begin

  result.YDiv100 := Y div 100;

  result.YMod100 := Y-(result.YDiv100*100); // * is always faster than div

end;

{$else}

function Div100(Y: word): TWordRec;

asm

  mov cl,100

  div cl // ah=remainder=Y mod 100, al=quotient=Year div 100

end;

{$endif}



procedure YearToPChar(Y: cardinal; P: PUTF8Char);

{$ifdef PUREPASCAL}

var d100: cardinal;

begin

  d100 := Y div 100;

  PWordArray(P)[0] := TwoDigitLookupW[d100];

  PWordArray(P)[1] := TwoDigitLookupW[Y-(d100*100)];

end;

{$else}

asm

  mov cl,100

  div cl // ah=remainder=Y mod 100, al=quotient=Year div 100

  movzx ecx,al // al=quotient=Y div 100

  mov cx,word ptr [TwoDigitLookup+ecx*2]

  mov [edx],cx

  movzx ecx,ah // ah=remainder=Y mod 100

  mov cx,word ptr [TwoDigitLookup+ecx*2]

  mov [edx+2],cx

end;

{$endif}



function UInt3DigitsToUTF8(Value: Cardinal): RawUTF8;

begin

  SetString(result,nil,3);

  PWordArray(result)[0] := TwoDigitLookupW[Value div 10];

  PByteArray(result)[2] := (Value mod 10)+48;

end;



function UInt4DigitsToUTF8(Value: Cardinal): RawUTF8;

begin

  SetString(result,nil,4);

  YearToPChar(Value,pointer(result));

end;



function UInt4DigitsToShort(Value: Cardinal): Short4;

begin

  result[0] := #4;

  YearToPChar(Value,@result[1]);

end;



function UInt3DigitsToShort(Value: Cardinal): Short4;

begin

  YearToPChar(Value,@result[0]);

  result[0] := #3; // override first digit

end;



function UInt2DigitsToShort(Value: byte): Short4;

begin

  result[0] := #2;

  if Value>99 then

    Value := 99;

  PWord(@result[1])^ := TwoDigitLookupW[Value];

end;





function SameValue(const A, B: Double; DoublePrec: double): Boolean;

var AbsA,AbsB: double;

begin // faster than the Math unit version

  AbsA := Abs(A);

  AbsB := Abs(B);

  if AbsA<AbsB then

    AbsA := AbsA*DoublePrec else

    AbsA := AbsB*DoublePrec; // AbsA := Min(Abs(A),Abs(B))*DoublePrec

  // AbsA is the allowed Epsilon value

  if AbsA<DoublePrec then

    Result := Abs(A-B)<=DoublePrec else

    Result := Abs(A-B)<=AbsA;

end;



function SameValueFloat(const A, B: TSynExtended; DoublePrec: TSynExtended): Boolean;

var AbsA,AbsB: TSynExtended;

begin // faster than the Math unit version

  AbsA := Abs(A);

  AbsB := Abs(B);

  if AbsA<AbsB then

    AbsA := AbsA*DoublePrec else

    AbsA := AbsB*DoublePrec; // AbsA := Min(Abs(A),Abs(B))*DoublePrec

  // AbsA is the allowed Epsilon value

  if AbsA<DoublePrec then

    Result := Abs(A-B)<=DoublePrec else

    Result := Abs(A-B)<=AbsA;

end;



/// return the index of Value in Values[], -1 if not found

function FindRawUTF8(const Values: TRawUTF8DynArray; const Value: RawUTF8;

  CaseSensitive: boolean=true): integer;

begin

  if CaseSensitive then begin

    for result := 0 to length(Values)-1 do

      if Values[result]=Value then

        exit;

  end else

    for result := 0 to length(Values)-1 do

      if UTF8IComp(pointer(Values[result]),pointer(Value))=0 then

        exit;

  result := -1;

end;



function FindRawUTF8(const Values: array of RawUTF8; const Value: RawUTF8;

  CaseSensitive: boolean=true): integer;

begin

  if CaseSensitive then begin

    for result := 0 to high(Values) do

      if Values[result]=Value then

        exit;

  end else

    for result := 0 to high(Values) do

      if UTF8IComp(pointer(Values[result]),pointer(Value))=0 then

        exit;

  result := -1;

end;



function FindRawUTF8(const Values: TRawUTF8DynArray; ValuesCount: integer;

  const Value: RawUTF8; SearchPropName: boolean): integer;

begin

  if SearchPropName then begin

    for result := 0 to ValuesCount-1 do

      if IdemPropNameU(Values[result],Value) then

        exit;

  end else

    for result := 0 to ValuesCount-1 do

      if Values[result]=Value then

        exit;

  result := -1;

end;



function FindPropName(const Names: array of RawUTF8; const Name: RawUTF8): integer;

{$ifdef HASINLINE}

var NameLen: integer;

begin

  NameLen := Length(Name);

  for result := 0 to high(Names) do

    if (Length(Names[result])=NameLen) and

       IdemPropNameUSameLen(pointer(Names[result]),pointer(Name),NameLen) then

      exit;

  result := -1;

end;

{$else}

begin

  for result := 0 to high(Names) do

    if IdemPropNameU(Names[result],Name) then

      exit;

  result := -1;

end;

{$endif}



/// true if Value was added successfully in Values[]

function AddRawUTF8(var Values: TRawUTF8DynArray; const Value: RawUTF8;

  NoDuplicates: boolean=false; CaseSensitive: boolean=true): boolean;

var i: integer;

begin

  if NoDuplicates then begin

    i := FindRawUTF8(Values,Value,CaseSensitive);

    if i>=0 then begin

      result := false;

      exit;

    end;

  end;

  i := length(Values);

  SetLength(Values,i+1);

  Values[i] := Value;

  result := true;

end;



procedure AddRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer;

  const Value: RawUTF8);

var capacity: integer;

begin

  capacity := Length(Values);

  if ValuesCount=capacity then begin

    inc(capacity,32+capacity shr 3);

    SetLength(Values,capacity);

  end;

  Values[ValuesCount] := Value;

  inc(ValuesCount);

end;



function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray): boolean;

var i: integer;

begin

  result := false;

  if length(A)<>length(B) then

    exit;

  for i := 0 to high(A) do

    if A[i]<>B[i] then

      exit;

  result := true;

end;





{ TPropNameList }



procedure TPropNameList.Init;

begin

  Count := 0;

end;



function TPropNameList.FindPropName(const Value: RawUTF8): Integer;

begin

  for result := 0 to Count-1 do

    if IdemPropNameU(Values[result],Value) then

      exit;

  result := -1;

end;



function TPropNameList.AddPropName(const Value: RawUTF8): Boolean;

begin

  if FindPropName(Value)<0 then begin

    if Count=length(Values) then

      SetLength(Values,Count+16);

    Values[Count] := Value;

    inc(Count);

    result := true;

  end else

    result := false;

end;





procedure StringDynArrayToRawUTF8DynArray(const Source: TStringDynArray;

  var Result: TRawUTF8DynArray);

var i: Integer;

begin

  SetLength(Result,length(Source));

  for i := 0 to high(Source) do

    StringToUTF8(Source[i],Result[i]);

end;



procedure StringListToRawUTF8DynArray(Source: TStringList; var Result: TRawUTF8DynArray);

var i: Integer;

begin

  SetLength(Result,Source.Count);

  for i := 0 to Source.Count-1 do

    StringToUTF8(Source[i],Result[i]);

end;



/// find the position of the SEARCH] section in source

// - return true if SEARCH] was found, and store line after it in source

function FindSectionFirstLine(var source: PUTF8Char; search: PAnsiChar): boolean;

{$ifdef PUREPASCAL}

begin

  result := false;

  if source=nil then

    exit;

  repeat

    if source^='[' then begin

      inc(source);

      result := IdemPChar(source,search);

    end;

    while source^ in ANSICHARNOT01310 do inc(source);

    while source^ in [#10,#13] do inc(source);

    if result then

      exit; // found

  until source^=#0;

  source := nil;

end;

{$else}

asm // eax=source edx=search

    push eax       // save source var

    mov eax,[eax]  // eax=source

    test eax,eax

    jz @z

    push ebx

    mov ebx,edx    // save search

    cmp byte ptr [eax],'['

    lea eax,[eax+1]

    jne @s

@i: push eax

    mov edx,ebx   // edx=search

    call IdemPChar

    pop ecx       // ecx=source

    jmp @1

@s: mov ecx,eax

    xor eax,eax   // result := false

@1: mov dl,[ecx]  // while not (source^ in [#0,#10,#13]) do inc(source);

    inc ecx

    cmp dl,13

    ja @1

    je @e

    or dl,dl

    jz @0

    cmp dl,10

    jne @1

    cmp byte [ecx],13

    jbe @1

    jmp @4

@e: cmp byte ptr [ecx],10 // jump #13#10

    jne @4

    inc ecx

@4: test al,al

    jnz @x         // exit if IdemPChar returned true

    cmp byte ptr [ecx],'['

    lea ecx,[ecx+1]

    jne @1

    mov eax,ecx

    jmp @i

@0: xor ecx,ecx    // set source=nil

@x: pop ebx

    pop edx        // restore source var

    mov [edx],ecx  // update source var

    ret

@z: pop edx       // ignore source var, result := false

end;

{$endif}



{$ifdef USENORMTOUPPER}

{$ifdef PUREPASCAL}

function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean;

// 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(NormToUpperByte[ord(p^)])) then

      exit;

    inc(up);

    inc(p);

  end;

  result := true;

end;

{$else}

function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean;

// if the beginning of p^ is same as up^ (ignore case - up^ must be already Upper)

// eax=p edx=up

asm

    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

    lea edx,[edx+1] // = inc edx without changing flags

    cmp bl,cl

    lea eax,[eax+2]

    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}

{$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}



function FindSectionFirstLineW(var source: PWideChar; search: PUTF8Char): boolean;

{$ifdef PUREPASCAL}

begin

  result := false;

  if source=nil then

    exit;

  repeat

    if source^='[' then begin

      inc(source);

      result := IdemPCharW(source,search);

    end;

    while not (cardinal(source^) in [0,10,13]) do inc(source);

    while cardinal(source^) in [10,13] do inc(source);

    if result then

      exit; // found

  until source^=#0;

  source := nil;

end;

{$else}

asm // eax=source edx=search

    push eax       // save source var

    mov eax,[eax]  // eax=source

    test eax,eax

    jz @z

    push ebx

    mov ebx,edx    // save search

    cmp word ptr [eax],'['

    lea eax,[eax+2]

    jne @s

@i: push eax

    mov edx,ebx   // edx=search

    call IdemPCharW

    pop ecx       // ecx=source

    jmp @1

@s: mov ecx,eax

    xor eax,eax   // result := false

@1: mov dx,[ecx]  // while not (source^ in [#0,#10,#13]) do inc(source);

    lea ecx,[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

    lea ecx,[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}



function FindIniNameValue(P: PUTF8Char; UpperName: PAnsiChar): RawUTF8;

var PBeg: PUTF8Char;

    i: integer;

begin // expect UpperName as 'NAME='

  PBeg := nil;

  if (P<>nil) and (P^<>'[') and (UpperName<>nil) then

  repeat

    if P^=' ' then repeat inc(P) until P^<>' ';   // trim left ' '

    if NormToUpperAnsi7[P[0]]=UpperName[0] then

      PBeg := P;

    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);

      if P^ in [#0,#10,#13] then

        break else

        inc(P);

    until false;

    if PBeg<>nil then begin

      i := 1;

      repeat

        if UpperName[i]<>#0 then

          if NormToUpperAnsi7[PBeg[i]]<>UpperName[i] then

            break else

            inc(i) else begin

          inc(PBeg,i);

          SetString(result,PBeg,P-PBeg);

          exit;

        end;

      until false;

      PBeg := nil;

    end;

    if P^=#13 then inc(P);

    if P^=#10 then inc(P);

  until P^ in [#0,'['];

  result := '';

end;



function ExistsIniName(P: PUTF8Char; UpperName: PAnsiChar): boolean;

var PBeg: PUTF8Char;

begin

  result := true;

  while (P<>nil) and (P^<>'[') do begin

    PBeg := GetNextLineBegin(P,P); // since PBeg=P, we have PBeg<>nil

    if PBeg^=' ' then repeat inc(PBeg) until PBeg^<>' ';   // trim left ' '

    if IdemPChar(PBeg,UpperName) then

      exit;

  end;

  result := false;

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

      PBeg := GetNextLineBegin(P,P); // since PBeg=P, we have PBeg<>nil

      if PBeg^=' ' then repeat inc(PBeg) until PBeg^<>' ';   // trim left ' '

      if IdemPChar(PBeg,pointer(UpperName)) then begin

        inc(PBeg,length(UpperName));

        if IdemPCharArray(PBeg,UpperValues)>=0 then

          exit; // found one value

        break;

      end;

    end;

  result := false;

end;



function FindWinAnsiIniNameValue(P: PUTF8Char; UpperName: PAnsiChar): RawUTF8;

begin

  result := WinAnsiToUtf8(RawByteString(FindIniNameValue(P,UpperName)));

end;



function GetSectionContent(SectionFirstLine: PUTF8Char): RawUTF8;

var PBeg: PUTF8Char;

begin

  PBeg := SectionFirstLine;

  while (SectionFirstLine<>nil) and (SectionFirstLine^<>'[') do

    GetNextLineBegin(SectionFirstLine,SectionFirstLine);

  if SectionFirstLine=nil then

    result := PBeg else

    SetString(result,PBeg,SectionFirstLine-PBeg);

end;



function GetSectionContent(const Content, SectionName: RawUTF8): RawUTF8; overload;

var P: PUTF8Char;

    UpperSection: array[byte] of AnsiChar;

begin

  P := pointer(Content);

  PWord(UpperCopy255(UpperSection,SectionName))^ := ord(']');

  if FindSectionFirstLine(P,UpperSection) then

    result := GetSectionContent(P) else

    result := '';

end;



function DeleteSection(var Content: RawUTF8; const SectionName: RawUTF8;

  EraseSectionHeader: boolean=true): boolean;

var P: PUTF8Char;

    UpperSection: array[byte] of AnsiChar;

begin

  result := false; // no modification

  P := pointer(Content);

  PWord(UpperCopy255(UpperSection,SectionName))^ := ord(']');

  if FindSectionFirstLine(P,UpperSection) then

    result := DeleteSection(P,Content,EraseSectionHeader);

end;



function DeleteSection(SectionFirstLine: PUTF8Char; var Content: RawUTF8;

  EraseSectionHeader: boolean=true): boolean;

var PEnd: PUTF8Char;

    IndexBegin: PtrInt;

begin

  result := false;

  PEnd := SectionFirstLine;

  if EraseSectionHeader then // erase [Section] header line

    while (PtrUInt(SectionFirstLine)>PtrUInt(Content)) and (SectionFirstLine^<>'[') do dec(SectionFirstLine);

  while (PEnd<>nil) and (PEnd^<>'[') do

    GetNextLineBegin(PEnd,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); overload;

var PEnd: PUTF8Char;

    IndexBegin: PtrInt;

begin

  if SectionFirstLine=nil then

    exit;

  // delete existing [Section] content

  PEnd := SectionFirstLine;

  while (PEnd<>nil) and (PEnd^<>'[') do

    GetNextLineBegin(PEnd,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): integer;

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;



procedure UpdateIniEntry(var Content: RawUTF8; const Section,Name,Value: RawUTF8);

const CRLF = #13#10;

var P: PUTF8Char;

    PBeg: PUTF8Char;

    SectionFound: boolean;

    i, UpperNameLength: PtrInt;

    V: RawUTF8;

    UpperSection, UpperName: array[byte] of AnsiChar;

    // possible GPF if length(Section/Name)>255, but should be short const in code

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;

    while (P<>nil) and (P^<>'[') do begin

      PBeg := GetNextLineBegin(P,P); // since PBeg=P, we have PBeg<>nil

      while PBeg^=' ' do inc(PBeg);   // trim left ' '

      if IdemPChar(PBeg,UpperName) then begin

        // update Name=Value entry

        inc(PBeg,UpperNameLength);

        i := (PBeg-pointer(Content))+1;

        if (i=length(Value)) and CompareMem(PBeg,pointer(Value),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(V,Content,i); // set new value

        exit;

      end;

    end;

    // 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): RawByteString;

var F: THandle;

    Size: integer;

begin

  result := '';

  if FileName='' then

    exit;

  F := FileOpenSequentialRead(FileName);

  if PtrInt(F)>=0 then begin

    Size := GetFileSize(F,nil);

    if Size>0 then begin

      SetLength(result,Size);

      if FileRead(F,pointer(result)^,Size)<>Size then

        result := '';

    end;

    FileClose(F);

  end;

end;



function FileFromString(const Content: RawByteString; const FileName: TFileName;

  FlushOnDisk: boolean=false): boolean;

var F: THandle;

    L: integer;

begin

  result := false;

  if FileName='' then

    exit;

  F := FileCreate(FileName);

  if PtrInt(F)<0 then

    exit;

  if pointer(Content)<>nil then

    L := FileWrite(F,pointer(Content)^,length(Content)) else

    L := 0;

  result := (L=length(Content));

{$ifdef MSWINDOWS}

  if FlushOnDisk then

    FlushFileBuffers(F);

{$endif}

  FileClose(F);

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(PtrInt(Map.Buffer)+2),(Map.Size-2) shr 1);

    isUTF8:

      UTF8ToSynUnicode(PUTF8Char(pointer(PtrInt(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(PtrInt(Map.Buffer)+2),(Map.Size-2) shr 1,Result);

    isUTF8:

      SetString(result,PAnsiChar(pointer(PtrInt(Map.Buffer)+3)),Map.Size-3);

    isAnsi:

      if AssumeUTF8IfNoBOM then

        SetString(result,PAnsiChar(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(PtrInt(Map.Buffer)+2),(Map.Size-2) shr 1);

    isUTF8:

      UTF8DecodeToString(pointer(PtrInt(Map.Buffer)+3),Map.Size-3,result);

    isAnsi:

      result := CurrentAnsiConvert.AnsiToUnicodeString(Map.Buffer,Map.Size);

{$else}

    isUnicode:

      result := CurrentAnsiConvert.UnicodeBufferToAnsi(PWideChar(PtrInt(Map.Buffer)+2),(Map.Size-2) shr 1);

    isUTF8:

      result := CurrentAnsiConvert.UTF8BufferToAnsi(pointer(PtrInt(Map.Buffer)+3),Map.Size-3);

    isAnsi:

      SetString(result,PAnsiChar(Map.Buffer),Map.Size);

{$endif}

    end;

  finally

    Map.UnMap;

  end;

end;



function StreamToRawByteString(aStream: TStream): RawByteString;

var current, size: Int64;

begin

  result := '';

  if aStream=nil then

    exit;

  current := aStream.Position;

  if (current=0) and aStream.InheritsFrom(TRawByteStringStream) then begin

    result := TRawByteStringStream(aStream).DataString; // fast COW

    exit;

  end;

  size := aStream.Size-current;

  if (size=0) or (size>maxInt) then

    exit;

  SetLength(result,size);

  aStream.Read(pointer(result)^,size);

  aStream.Position := current;

end;



function RawByteStringToStream(const aString: RawByteString): TStream;

begin

  result := TRawByteStringStream.Create(aString);

end;



function ReadStringFromStream(S: TStream; MaxAllowedSize: integer): RawUTF8;

var L: integer;

begin

  result := '';

  L := 0;

  if (S.Read(L,4)<>4) or (L<=0) or (L>MaxAllowedSize) then

    exit;

  SetLength(result,L);

  if S.Read(pointer(result)^,L)<>L then

    result := '';

end;



function WriteStringToStream(S: TStream; const Text: RawUTF8): boolean;

var L: integer;

begin

  L := length(Text);

  if L=0 then

    result := S.Write(L,4)=4 else

    {$ifdef FPC}

    result := (S.Write(L,4)=4) and (S.Write(pointer(Text)^,L)=L);

    {$else}

    result := S.Write(pointer(PtrInt(Text)-sizeof(integer))^,L+4)=L+4;

    {$endif}

end;



function GetFileNameWithoutExt(const FileName: TFileName): TFileName;

var i, max: PtrInt;

begin

  i := length(FileName);

  max := i-8;

  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

    result := FileName else

    SetString(result,PChar(pointer(FileName)),i-1);

end;



function GetFileNameExtIndex(const FileName, CSVExt: TFileName): integer;

var Ext: TFileName;

    P: PChar;

begin

  result := -1;

  P := pointer(CSVExt);

  Ext := ExtractFileExt(FileName);

  if (P=nil) or (Ext='') or (Ext[1]<>'.') then

    exit;

  delete(Ext,1,1);

  repeat

    inc(result);

    if SameText(GetNextItemString(P),Ext) then

      exit;

  until P=nil;

  result := -1;

end;



function FileSize(const FileName: TFileName): Int64;

{$ifdef MSWINDOWS}

var FA: WIN32_FILE_ATTRIBUTE_DATA;

begin // 5 times faster than CreateFile, GetFileSizeEx, CloseHandle

  if GetFileAttributesEx(pointer(FileName),GetFileExInfoStandard,@FA) then begin

    PInt64Rec(@result)^.Lo := FA.nFileSizeLow;

    PInt64Rec(@result)^.Hi := FA.nFileSizeHigh;

  end else

    result := 0;

end;          

{$else}

var f: THandle;

    res: Int64Rec absolute result;

begin

  result := 0;

  f := FileOpen(FileName,fmOpenRead or fmShareDenyNone);

  if PtrInt(f)>0 then begin

    res.Lo := GetFileSize(f,@res.Hi); // from SynKylix/SynFPCLinux

    FileClose(f);

  end;

end;

{$endif}



function 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 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

        {$ifndef DELPHI5OROLDER}

        {$WARN SYMBOL_DEPRECATED OFF} // for faVolumeID

        {$endif}

        if (F.Attr and (faDirectory+faVolumeID+faSysFile+faHidden)=0) and

           (F.Name[1]<>'.') then

          if DeleteFile(Dir+F.Name) then

            inc(n) else

            result := false;

        {$ifndef DELPHI5OROLDER}

        {$WARN SYMBOL_DEPRECATED ON}

        {$endif}

      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): Boolean;

var F: TSearchRec;

    Dir: TFileName;

    old: TDateTime;

begin

  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) else

        {$ifndef DELPHI5OROLDER}

        {$WARN SYMBOL_DEPRECATED OFF} // for faVolumeID

        {$endif}

        if (F.Attr and (faDirectory+faVolumeID+faSysFile+faHidden)=0) then

          if SearchRecToDateTime(F) < old then

            if not DeleteFile(Dir+F.Name) then

              result := false;

        {$ifndef DELPHI5OROLDER}

        {$WARN SYMBOL_DEPRECATED ON}

        {$endif}

    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 bits on older Delphi

  Size := F.FindData.nFileSizeLow or Int64(F.FindData.nFileSizeHigh) shl 32;

  {$endif}

  {$else}

  Size := F.Size;

  {$endif}

  Attr := F.Attr;

  TimeStamp := SearchRecToDateTime(F);

end;



function FindFiles(const Directory,Mask,IgnoreFileName: TFileName;

  SortByName, IncludesDir: boolean): TFindFilesDynArray;

var F: TSearchRec;

    n: integer;

    Dir: TFileName;

    da: TDynArray;

    masks: TRawUTF8DynArray;

    masked: TFindFilesDynArray;

begin

  result := nil;

  n := 0;

  da.Init(TypeInfo(TFindFilesDynArray),result);

  if Pos(';',Mask)>0 then

    CSVToRawUTF8DynArray(pointer(StringToUTF8(Mask)),masks,';');

  if masks<>nil then begin

    if SortByName then

      QuickSortRawUTF8(masks,length(masks),nil,@StrIComp);

    for n := 0 to high(masks) do begin

      masked := FindFiles(Directory,UTF8ToString(masks[n]),

        IgnoreFileName,SortByName,IncludesDir);

      da.AddArray(masked);

    end;

  end else begin

    Dir := IncludeTrailingPathDelimiter(Directory);

    if FindFirst(Dir+Mask,faAnyfile-faDirectory,F)=0 then begin

      repeat

        {$ifndef DELPHI5OROLDER}

        {$WARN SYMBOL_DEPRECATED OFF} // for faVolumeID

        {$endif}

        if (F.Attr and (faDirectory+faVolumeID+faSysFile+faHidden)=0) and

           (F.Name[1]<>'.') and ((IgnoreFileName='') or

            (AnsiCompareFileName(F.Name,IgnoreFileName)<>0)) then begin

          if n=length(result) then

            SetLength(result,n+n shr 3+8);

          if IncludesDir then

            result[n].FromSearchRec(Dir,F) else

            result[n].FromSearchRec('',F);

          inc(n);

        end;

        {$ifndef DELPHI5OROLDER}

        {$WARN SYMBOL_DEPRECATED ON}

        {$endif}

      until FindNext(F)<>0;

      FindClose(F);

      if n=0 then

        exit;

      SetLength(result,n);

    end;

    if SortByName and (n>0) then

      da.Sort(SortDynArrayStringI);

  end;

end;



function EnsureDirectoryExists(const Directory: TFileName;

  RaiseExceptionOnCreationFailure: boolean=false): TFileName;

begin

  result := IncludeTrailingPathDelimiter(ExpandFileName(Directory));

  if not DirectoryExists(result) then

    if not CreateDir(result) then

      if not RaiseExceptionOnCreationFailure then

        result := '' else

        raise ESynException.CreateUTF8('Impossible to create "%" folder',[Directory]);

end;



{$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;

var Code: Integer;

begin

  Code := GetFileAttributes(pointer(Directory));

  result := (Code<>-1) and (FILE_ATTRIBUTE_DIRECTORY and Code<>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<SizeOf(Buffer) then

    SetString(result,Buffer,Len) else begin

    SetLength(result,Len-1);

    Windows.GetEnvironmentVariable(pointer(Name),pointer(result),Len);

  end;

end;



function GetModuleName(Module: HMODULE): TFileName;

var tmp: array[byte] of char;

begin

  SetString(Result,tmp,GetModuleFileName(Module,tmp,SizeOf(tmp)));

end;



function TryEncodeTime(Hour, Min, Sec, MSec: Word; var Time: TDateTime): Boolean;

begin

  if (Hour<24) and (Min<60) and (Sec<60) and (MSec<1000) then begin

    Time := (Hour*3600000+Min*60000+Sec*1000+MSec)/MSecsPerDay;

    result := true;

  end else

    result := false;

end;



function ExcludeTrailingPathDelimiter(const FileName: TFileName): TFileName;

begin

  result := ExcludeTrailingBackslash(FileName);

end;



function IncludeTrailingPathDelimiter(const FileName: TFileName): TFileName;

begin

  result := IncludeTrailingBackslash(FileName);

end;



procedure RaiseLastOSError;

var LastError: Integer;

    Error: EOSError;

begin

  LastError := GetLastError;

  if LastError <> 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}



function FileSetDateFrom(const Dest: TFileName; SourceHandle: integer): boolean;

{$ifdef MSWINDOWS}

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}

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 IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean;

{$ifdef PUREPASCAL}

var i: PtrInt; // very optimized code for speed

begin

  if P<>nil then begin

    result := true;

    for i := 1 to (Count shr 2) do   // 4 DWORD by loop - aligned read

      if (P^[0]=Value) or (P^[1]=Value) or

         (P^[2]=Value) or (P^[3]=Value) then

        exit else

        inc(PtrUInt(P),sizeof(P^[0])*4);

    for i := 0 to (Count and 3)-1 do // last 0..3 DWORD

      if P^[i]=Value then

        exit;

  end;

  result := false;

end;

{$else}

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]

        nop // align @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

        cmp edx,8

        lea eax,[eax+32] // preserve flags during 'cmp edx,8' computation

@s2:    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;

{$endif}



function Int64ScanExists(P: PInt64Array; Count: PtrInt; const Value: Int64): boolean;

var i: PtrInt;

begin

  if P<>nil then begin

    result := true;

    for i := 1 to (Count shr 2) do   // 4 QWORD by loop - aligned read

      if (P^[0]=Value) or (P^[1]=Value) or

         (P^[2]=Value) or (P^[3]=Value) then

        exit else

        inc(PtrUInt(P),sizeof(P^[0])*4);

    for i := 0 to (Count and 3)-1 do // last 0..3 QWORD

      if P^[i]=Value then

        exit;

  end;

  result := false;

end;



function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal;

{$ifdef PUREPASCAL}

var i: PtrInt;

begin // very optimized code

  if P<>nil then begin

    for i := 1 to Count shr 2 do      // 4 DWORD by loop - aligned read

      if P^[0]<>Value then

      if P^[1]<>Value then

      if P^[2]<>Value then

      if P^[3]=Value then begin

        result := @P^[3];

        exit;

      end else

        inc(PtrUInt(P),sizeof(P^[0])*4) else begin

        result := @P^[2];

        exit;

      end else begin

        result := @P^[1];

        exit;

      end else begin

        result := pointer(P);

        exit;

      end;

    for i := 0 to (Count and 3)-1 do  // last 0..3 DWORD

      if P^[i]=Value then begin

        result := @P^[i];

        exit;

      end;

  end;

  result := nil;

end;

{$else}

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

       cmp edx,8

       lea eax,[eax+32]  // preserve flags during 'cmp edx,8' computation

       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: lea eax,[eax+28]; ret

@ok24: lea eax,[eax+24]; ret

@ok20: lea eax,[eax+20]; ret

@ok16: lea eax,[eax+16]; ret

@ok12: lea eax,[eax+12]; ret

@ok8:  lea eax,[eax+8];  ret

@ok4:  lea eax,[eax+4]

end;

{$endif}



function Int64Scan(P: PInt64Array; Count: PtrInt; const Value: Int64): PInt64;

var i: PtrInt;

begin

  if P<>nil then begin

    for i := 1 to Count shr 2 do      // 4 QWORD by loop - aligned read

      if P^[0]<>Value then

      if P^[1]<>Value then

      if P^[2]<>Value then

      if P^[3]=Value then begin

        result := @P^[3];

        exit;

      end else

        inc(PtrUInt(P),sizeof(P^[0])*4) else begin

        result := @P^[2];

        exit;

      end else begin

        result := @P^[1];

        exit;

      end else begin

        result := pointer(P);

        exit;

      end;

    for i := 0 to (Count and 3)-1 do  // last 0..3 QWORD

      if P^[i]=Value then begin

        result := @P^[i];

        exit;

      end;

  end;

  result := nil;

end;



function AddInteger(var Values: TIntegerDynArray; Value: integer;

  NoDuplicates: boolean=false): boolean;

var n: PtrInt;

begin

  n := Length(Values);

  if NoDuplicates and IntegerScanExists(pointer(Values),n,Value) then begin

    result := false;

    exit;

  end;

  SetLength(Values,n+1);

  Values[n] := Value;

  result := true

end;



procedure AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer;

  Value: integer);

begin

  if ValuesCount=length(Values) then

    SetLength(Values,ValuesCount+256+ValuesCount shr 3);

  Values[ValuesCount] := Value;

  inc(ValuesCount);

end;



function AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer;

  Value: integer; NoDuplicates: boolean): boolean; overload;

begin

  if NoDuplicates and IntegerScanExists(pointer(Values),ValuesCount,Value) then begin

    result := false;

    exit;

  end;

  if ValuesCount=length(Values) then

    SetLength(Values,ValuesCount+256+ValuesCount shr 3);

  Values[ValuesCount] := Value;

  inc(ValuesCount);

  result := true

end;



procedure AddInt64(var Values: TInt64DynArray; var ValuesCount: integer; Value: Int64);

begin

  if ValuesCount=length(Values) then

    SetLength(Values,ValuesCount+256+ValuesCount shr 3);

  Values[ValuesCount] := Value;

  inc(ValuesCount);

end;



procedure AddInt64(var Values: TInt64DynArray; Value: Int64);

var n: integer;

begin

  n := length(Values);

  SetLength(Values,n+1);

  Values[n] := Value;

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

    MoveFast(Values[Index+1],Values[Index],(n-Index)*sizeof(Integer));

  SetLength(Values,n);

end;



procedure DeleteInt64(var Values: TInt64DynArray; Index: PtrInt); overload;

var n: PtrInt;

begin

  n := Length(Values);

  if PtrUInt(Index)>=PtrUInt(n) then

    exit; // wrong Index

  dec(n);

  if n>Index then

    MoveFast(Values[Index+1],Values[Index],(n-Index)*sizeof(Int64));

  SetLength(Values,n);

end;



procedure DeleteInteger(var Values: TIntegerDynArray; var ValuesCount: Integer; Index: PtrInt); overload;

var n: PtrInt;

begin

  n := ValuesCount;

  if PtrUInt(Index)>=PtrUInt(n) then

    exit; // wrong Index

  dec(n,Index+1);

  if n>0 then

    MoveFast(Values[Index+1],Values[Index],n*sizeof(Integer));

  dec(ValuesCount);

end;



function MaxInteger(const Values: TIntegerDynArray; ValuesCount, MaxStart: integer): Integer;

var i: integer;

begin

  result := MaxStart;

  for i := 0 to ValuesCount-1 do

    if Values[i]>result then

      result := Values[i];

end;



procedure Reverse(const Values: TIntegerDynArray; ValuesCount: integer;

  Reversed: PIntegerArray);

var i: integer;

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 FillIncreasing(Values: PIntegerArray; StartValue, Count: integer);

var i: integer;

begin

  if StartValue=0 then

    for i := 0 to Count-1 do

      Values[i] := i else

    for i := 0 to Count-1 do

      Values[i] := StartValue+i;

end;



procedure Int64ToUInt32(Values64: PInt64Array; Values32: PCardinalArray; Count: integer);

var i: integer;

begin

  for i := 0 to Count-1 do

    Values32[i] := Values64[i];

end;



procedure CSVToIntegerDynArray(CSV: PUTF8Char; var Result: TIntegerDynArray);

begin

  while CSV<>nil do begin

    SetLength(Result,length(Result)+1);

    Result[high(Result)] := GetNextItemInteger(CSV);

  end;

end;



procedure CSVToInt64DynArray(CSV: PUTF8Char; var Result: TInt64DynArray);

begin

  while CSV<>nil do begin

    SetLength(Result,length(Result)+1);

    Result[high(Result)] := GetNextItemInt64(CSV);

  end;

end;



function IntegerDynArrayToCSV(const Values: array of integer; ValuesCount: integer;

  const Prefix: RawUTF8=''; const Suffix: RawUTF8=''): 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;

begin

  result := '';

  if ValuesCount=0 then

    exit;

  GetMem(ints,ValuesCount*sizeof(ints[0])); // getmem is faster than a dynamic array

  try

     // compute whole result length at once

    dec(ValuesCount);

    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<ValuesCount then

        inc(L); // append tmp[15]=','

      inc(Len,L);

      SetString(ints[i],P,L);

    end;

    // create result

    SetLength(result,Len);

    P := pointer(result);

    if Prefix<>'' then begin

      MoveFast(pointer(Prefix)^,P^,length(Prefix));

      inc(P,length(Prefix));

    end;

    for i := 0 to ValuesCount do begin

      MoveFast(ints[i][1],P^,ord(ints[i][0]));

      inc(P,ord(ints[i][0]));

    end;

    if Suffix<>'' then

      MoveFast(pointer(Suffix)^,P^,length(Suffix));

  finally

    FreeMem(ints);

  end;

end;



function Int64DynArrayToCSV(const Values: array of Int64; ValuesCount: integer;

  const Prefix: RawUTF8=''; const Suffix: RawUTF8=''): RawUTF8;

type

  TInt = packed record

    Len: byte;

    Val: array[0..19] of AnsiChar; // Int64: 19 digits, then - sign

  end;

var i, L, Len: PtrInt;

    ints: pointer;

    int: ^TInt;

    P: PAnsiChar;

begin

  result := '';

  if ValuesCount=0 then

    exit;

  GetMem(ints,ValuesCount*sizeof(TInt)); // getmem is faster than a dynamic array

  try

     // compute whole result length at once

    dec(ValuesCount);

    Len := length(Prefix)+length(Suffix);

    int := ints;

    for i := 0 to ValuesCount do begin

      P := StrInt64(PAnsiChar(int)+21,Values[i]);

      L := PAnsiChar(int)+21-P;

      int^.Len := L;

      if i<ValuesCount then

        inc(L); // for ,

      inc(Len,L);

      inc(int);

    end;

    // create result

    SetLength(result,Len);

    P := pointer(result);

    if Prefix<>'' then begin

      MoveFast(pointer(Prefix)^,P^,length(Prefix));

      inc(P,length(Prefix));

    end;

    int := ints;

    repeat

      L := int^.Len;

      MoveFast(PAnsiChar(int)[21-L],P^,L);

      inc(P,L);

      if ValuesCount=0 then

        break;

      inc(int);

      P^ := ',';

      inc(P);

      dec(ValuesCount);

    until false;

    if Suffix<>'' then

      MoveFast(pointer(Suffix)^,P^,length(Suffix));

  finally

    FreeMem(ints);

  end;

end;



function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt;

{$ifdef PUREPASCAL}

var i: PtrInt; // very optimized code for speed

begin

  if P<>nil then begin

    result := 0;

    for i := 1 to Count shr 2 do // 4 DWORD by loop - aligned read

      if P^[0]<>Value then

      if P^[1]<>Value then

      if P^[2]<>Value then

      if P^[3]<>Value then begin

        inc(PtrUInt(P),sizeof(P^[0])*4);

        inc(result,4);

      end else begin

        inc(result,3);

        exit;

      end else begin

        inc(result,2);

        exit;

      end else begin

        inc(result,1);

        exit;

      end else

        exit;

    for i := 0 to (Count and 3)-1 do // last 0..3 DWORD

      if P^[i]=Value then

        exit else

        inc(result);

  end;

  result := -1;

end;

{$else}

asm

    push eax

    call IntegerScan

    test eax,eax

    pop edx

    jnz @e

    dec eax // returns -1

    ret

@e: sub eax,edx

    shr eax,2

end;

{$endif}



function PtrUIntScanExists(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): boolean;

{$ifdef PUREPASCAL}

begin

  {$ifdef CPU64}

  result := Int64ScanExists(pointer(P),Count,Value);

  {$else}

  result := IntegerScanExists(pointer(P),Count,Value);

  {$endif}

end;

{$else}

asm

  jmp IntegerScanExists;

end;

{$endif}



function PtrUIntScanIndex(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): PtrInt;

{$ifdef PUREPASCAL}

var i: PtrInt; // optimized code for speed

begin

  if P<>nil then begin

    result := 0;

    for i := 1 to Count shr 2 do // 4 PtrUInt by loop - aligned read

      if P^[0]<>Value then

      if P^[1]<>Value then

      if P^[2]<>Value then

      if P^[3]<>Value then begin

        inc(PtrUInt(P),sizeof(P^[0])*4);

        inc(result,4);

      end else begin

        inc(result,3);

        exit;

      end else begin

        inc(result,2);

        exit;

      end else begin

        inc(result,1);

        exit;

      end else

        exit;

    for i := 0 to (Count and 3)-1 do // last 0..3 PtrUInt

      if P^[i]=Value then

        exit else

        inc(result);

  end;

  result := -1;

end;

{$else}

asm

    push eax

    call IntegerScan

    test eax,eax

    pop edx

    jnz @e

    dec eax // returns -1

    ret

@e: sub eax,edx

    shr eax,2

end;

{$endif}



function WordScanIndex(P: PWordArray; Count: PtrInt; Value: word): integer;

begin

  for result := 0 to Count-1 do

    if P^[result]=Value then

      exit;

  result := -1;

end;



procedure QuickSortInteger(ID: PIntegerArray; L,R: PtrInt);

var I, J, P: PtrInt;

    pivot, Tmp: integer;

begin

  if L<R then

  repeat

    I := L; J := R;

    P := (L + R) shr 1;

    repeat

      pivot := ID^[P];

      while ID[I]<pivot do inc(I);

      while ID[J]>pivot 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 L < J then

      QuickSortInteger(ID,L,J);

    L := I;

  until I >= 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;

    pivot, Tmp: integer;

begin

  if L<R then

  repeat

    I := L; J := R;

    P := (L + R) shr 1;

    repeat

      pivot := ID^[P];

      while ID[I]<pivot do inc(I);

      while ID[J]>pivot do dec(J);

      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 L < J then

      QuickSortInteger(ID,CoValues,L,J);

    L := I;

  until I >= R;

end;



procedure QuickSortInt64(ID: PInt64Array; L, R: PtrInt); overload;

var I, J, P: PtrInt;

    pivot, Tmp: Int64;

begin

  if L<R then

  repeat

    I := L; J := R;

    P := (L + R) shr 1;

    repeat

      pivot := ID^[P];

      while ID[I]<pivot do inc(I);

      while ID[J]>pivot 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 L < J then

      QuickSortInt64(ID,L,J);

    L := I;

  until I >= R;

end;



procedure QuickSortInt64(ID,CoValues: PInt64Array; L, R: PtrInt); overload;

var I, J, P: PtrInt;

    pivot, Tmp: Int64;

begin

  if L<R then

  repeat

    I := L; J := R;

    P := (L + R) shr 1;

    repeat

      pivot := ID^[P];

      while ID[I]<pivot do inc(I);

      while ID[J]>pivot do dec(J);

      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 L < J then

      QuickSortInt64(ID,L,J);

    L := I;

  until I >= 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; overload;

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; overload;

begin

  {$ifdef CPU64}

  result := FastFindInt64Sorted(PInt64Array(P),R,Int64(Value));

  {$else}

  result := FastFindIntegerSorted(PIntegerArray(P),R,integer(Value));

  {$endif}

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;

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

      L := result + 1 else

      R := result - 1;

  until (L > R);

  result := -1

end;



function FastFindInt64Sorted(P: PInt64Array; R: PtrInt; const Value: Int64): PtrInt; overload;

var L: PtrInt;

    cmp: Int64;

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

      L := result + 1 else

      R := result - 1;

  until (L > R);

  result := -1

end;



function FastFindIntegerSorted(const Values: TIntegerDynArray; Value: integer): PtrInt;

begin

  result := FastFindIntegerSorted(pointer(Values),length(Values)-1,Value);

end;



function FastLocateIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt;

var L,i: PtrInt;

   cmp: integer;

begin

  if R<0 then

    result := 0 else begin

    L := 0;

    result := -1; // return -1 if found

    repeat

      i := (L + R) shr 1;

      cmp := 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 (P^[i]>=Value) do dec(i);

    result := i+1; // return the index where to insert

  end;

end;



function AddSortedInteger(var Values: TIntegerDynArray; var ValuesCount: integer;

  Value: integer; CoValues: PIntegerDynArray=nil): PtrInt;

begin

  result := FastLocateIntegerSorted(pointer(Values),ValuesCount-1,Value);

  if result>=0 then // if Value exists -> fails

    result := InsertInteger(Values,ValuesCount,Value,result,CoValues);

end;



function AddSortedInteger(var Values: TIntegerDynArray;

  Value: integer; CoValues: PIntegerDynArray=nil): PtrInt;

var ValuesCount: integer;

begin

  ValuesCount := length(Values);

  result := FastLocateIntegerSorted(pointer(Values),ValuesCount-1,Value);

  if result>=0 then begin // if Value exists -> fails

    SetLength(Values,ValuesCount+1); // manual size increase

    result := InsertInteger(Values,ValuesCount,Value,result,CoValues);

  end;

end;



function InsertInteger(var Values: TIntegerDynArray; var ValuesCount: integer;

  Value: Integer; Index: PtrInt; CoValues: PIntegerDynArray=nil): PtrInt;

var n: PtrInt;

begin

  result := Index;

  n := Length(Values);

  if ValuesCount=n then begin

    inc(n,256+n shr 3);

    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: integer;

begin

  SetLength(result,length(Values));

  for i := 0 to high(Values) do

    result[i] := Values[i];

end;



function TIntegerDynArrayFrom64(const Values: TInt64DynArray;

  raiseExceptionOnOverflow: boolean=true): TIntegerDynArray;

var i: integer;

const MinInt = -MaxInt-1;

begin

  SetLength(result,length(Values));

  for i := 0 to high(Values) do

    if Values[i]>MaxInt then

      if raiseExceptionOnOverflow then

        raise ESynException.CreateUTF8('TIntegerDynArrayFrom64: Values[%]=%>%',

          [i,Values[i],MaxInt]) else

        result[i] := MaxInt else

    if Values[i]<MinInt then

      if raiseExceptionOnOverflow then

        raise ESynException.CreateUTF8('TIntegerDynArrayFrom64: Values[%]=%<%',

          [i,Values[i],MinInt]) else

        result[i] := MinInt else

    result[i] := Values[i];

end;



function TInt64DynArrayFrom(const Values: TIntegerDynArray): TInt64DynArray;

var i: integer;

begin

  SetLength(result,length(Values));

  for i := 0 to high(Values) do

    result[i] := Values[i];

end;



function GetInteger(P: PUTF8Char): PtrInt;

var c: PtrUInt;

    minus: boolean;

begin

  if P=nil then begin

    result := 0;

    exit;

  end;

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  if P^='-' then begin

    minus := true;

    repeat inc(P) until P^<>' ';

  end else begin

    minus := false;

    if P^='+' then

      repeat inc(P) until P^<>' ';

  end;

  c := byte(P^)-48;

  if c>9 then

    result := 0 else begin

    result := c;

    inc(P);

    repeat

      c := byte(P^)-48;

      if c>9 then

        break else

        result := result*10+PtrInt(c);

      inc(P);

    until false;

  end;

  if minus then

    result := -result;

end;



function GetInteger(P: PUTF8Char; var err: integer): PtrInt;

var c: PtrUInt;

    minus: boolean;

begin

  if P=nil then begin

    result := 0;

    err := 1;

    exit;

  end else

    err := 0;

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  if P^='-' then begin

    minus := true;

    repeat inc(P) until P^<>' ';

  end else begin

    minus := false;

    if P^='+' then

      repeat inc(P) until P^<>' ';

  end;

  c := byte(P^)-48;

  if c>9 then begin

    err := 1;

    result := 0;

    exit;

  end else begin

    result := c;

    inc(P);

    repeat

      c := byte(P^)-48;

      if c>9 then begin

        if byte(P^)<>0 then

          err := 1; // always return 1 as err code -> don't care about char index

        break;

      end else

        result := result*10+PtrInt(c);

      inc(P);

    until false;

  end;

  if minus then

    result := -result;

end;



function GetIntegerDef(P: PUTF8Char; Default: PtrInt): PtrInt;

var err: integer;

begin

  result := GetInteger(P,err);

  if err<>0 then

    result := Default;

end;



function UTF8ToInteger(const value: RawUTF8; Default: PtrInt=0): PtrInt;

var err: integer;

begin

  result := GetInteger(pointer(value),err);

  if err<>0 then

    result := Default;

end;



function UTF8ToInteger(const value: RawUTF8; Min,Max: PtrInt; Default: PtrInt=0): PtrInt;

var err: integer;

begin

  result := GetInteger(pointer(value),err);

  if (err<>0) or (result<Min) or (result>Max) then

    result := Default;

end;



function GetBoolean(P: PUTF8Char): boolean;

begin

  if (P<>nil) and (PInteger(P)^=TRUE_LOW) then

    result := true else

    result := GetInteger(P)<>0;

end;



function GetCardinalDef(P: PUTF8Char; Default: PtrUInt): PtrUInt;

var c: PtrUInt;

begin

  if P=nil then begin

    result := Default;

    exit;

  end;

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  c := byte(P^)-48;

  if c>9 then

    result := Default else begin

    result := c;

    inc(P);

    repeat

      c := byte(P^)-48;

      if c>9 then

        break else

        result := result*10+PtrUInt(c);

      inc(P);

    until false;

  end;

end;



function GetCardinal(P: PUTF8Char): PtrUInt;

var c: PtrUInt;

begin

  if P=nil then begin

    result := 0;

    exit;

  end;

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  c := byte(P^)-48;

  if c>9 then

    result := 0 else begin

    result := c;

    inc(P);

    repeat

      c := byte(P^)-48;

      if c>9 then

        break else

        result := result*10+PtrUInt(c);

      inc(P);

    until false;

  end;

end;



function GetCardinalW(P: PWideChar): PtrUInt;

var c: PtrUInt;

begin

  if P=nil then begin

    result := 0;

    exit;

  end;

  if ord(P^) in [1..32] then repeat inc(P) until not(ord(P^) in [1..32]);

  c := word(P^)-48;

  if c>9 then

    result := 0 else begin

    result := c;

    inc(P);

    repeat

      c := word(P^)-48;

      if c>9 then

        break else

        result := result*10+c;

      inc(P);

    until false;

  end;

end;



{$ifdef CPU64}

procedure SetInt64(P: PUTF8Char; var result: Int64);

begin // PtrInt is already int64 -> call PtrInt version

  result := GetInteger(P);

end;

{$else}

procedure SetInt64(P: PUTF8Char; var result: Int64);

var c: cardinal;

    minus: boolean;

begin

  result := 0;

  if P=nil then

    exit;

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  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;

  Int64Rec(result).Lo := c;

  inc(P);

  repeat // fast 32 bit loop

    c := byte(P^)-48;

    if c>9 then

      break else

      Int64Rec(result).Lo := Int64Rec(result).Lo*10+c;

    inc(P);

    if Int64Rec(result).Lo>=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}

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}



{$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;

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  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;

  Int64Rec(result).Lo := 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;

      Int64Rec(result).Lo := Int64Rec(result).Lo*10+c;

      inc(P);

      if Int64Rec(result).Lo>=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

            result := result shl 3+result+result; // fast result := result*10

          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 GetExtended(P: PUTF8Char): TSynExtended;

var err: integer;

begin

  result := GetExtended(P,err);

  if err<>0 then

    result := 0;

end;



{$ifdef PUREPASCAL}

  {$define GETEXTENDEDPASCAL}

{$endif}

{$ifdef FPC}

  {$define GETEXTENDEDPASCAL}

{$endif}

{$ifdef PIC}

  {$define GETEXTENDEDPASCAL}

{$endif}



function GetExtended(P: PUTF8Char; out err: integer): TSynExtended;

// adapted from ValExt_JOH_PAS_8_a and ValExt_JOH_IA32_8_a by John O'Harrow

{$ifdef GETEXTENDEDPASCAL}

const POW10: array[0..31] of TSynExtended = (

  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);

function IntPower(Exponent: Integer): TSynExtended;

var Y: Cardinal;

    LBase: Int64;

begin

  Y := abs(Exponent);

  LBase := 10;

  result := 1.0;

  repeat

    while not odd(Y) do begin

      Y := Y shr 1;

      LBase := LBase*LBase;

    end;

    dec(Y);

    result := result*LBase;

  until Y=0;

  if Exponent<0 then

    result := 1.0/result;

end;

var Digits, ExpValue: Integer;

    Ch: AnsiChar;

    Neg, NegExp, Valid: Boolean;

begin

  result := 0.0;

  err := 0;

  if P=nil then begin

    inc(err);

    exit;

  end;

  Neg := False;

  NegExp := False;

  Valid := False;

  while P[err]=' ' do

    inc(err);

  Ch := P[err];

  if Ch in ['+','-'] then begin

    inc(err);

    Neg := (Ch='-');

  end;

  while true do begin

    Ch := P[err];

    inc(err);

    if not (Ch in ['0'..'9']) then

      break;

    result := (result*10.0)+Ord(Ch)-Ord('0');

    Valid := True;

  end;

  Digits := 0;

  if Ch='.' then begin

    while true do begin

      Ch := P[err];

      inc(err);

      if not (Ch in ['0'..'9']) then begin

        if not valid then // starts with '.'

          if Ch=#0 then

            dec(err); // P='.'

        break;

      end;

      result := (result*10.0)+Ord(Ch)-Ord('0');

      dec(Digits);

      Valid := true;

    end;

    end;

  ExpValue := 0;

  if Ch in ['E','e'] then begin

    Valid := false;

    Ch := P[err];

    if Ch in ['+','-'] then begin

      inc(err);

      NegExp := (Ch='-');

    end;

    while true do begin

      Ch := P[err];

      inc(err);

      if not (Ch in ['0'..'9']) then

        break;

      ExpValue := (ExpValue*10)+Ord(Ch)-Ord('0');

      Valid := true;

    end;

   if NegExp then

     ExpValue := -ExpValue;

  end;

  inc(Digits,ExpValue);

  case Digits of

  -high(POW10)..-1: result := result/POW10[-Digits];

  1..high(POW10):   result := result*POW10[Digits];

  0: ;

  else result := result*IntPower(Digits);

  end;

  if Neg then

    result := -result;

  if Valid and (ch=#0) then

    err := 0;

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:                 {Strip Leading Spaces}

  movzx ebx,byte ptr [esi]

  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    @@CheckSign     {Check for Sign Character}

@@FirstDigit:

  xor   edi,edi         {Zero Exponent Value}

@@DigitLoop:

  sub   bl,'0'

  cmp   bl,9

  ja    @@Fraction      {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   @@DigitLoop     {No,Get Next Digit}

  jmp   @@Finish        {Yes,Finished}

@@CheckSign:

  cmp   bl,'-'

  je    @@Minus

  cmp   bl,'+'

  je    @@SignSet

@@GetFirstDigit:

  test  bl,bl

  jz    @@Error         {No Digits Found}

  jmp   @@FirstDigit

@@Minus:

  mov   ch,1            {Set Sign Flag}

@@SignSet:

  movzx ebx,byte ptr [esi]  {Get Next Char}

  inc   esi

  jmp   @@GetFirstDigit

@@Fraction:

  cmp   bl,'.'-'0'

  jne   @@Exponent      {No Decimal Point}

  movzx ebx,byte ptr [esi]   {Get Next Char}

  test  bl,bl

  jz    @@DotEnd        {String Ends with '.'}

  inc   esi

@@FractionLoop:

  sub   bl,'0'

  cmp   bl,9

  ja    @@Exponent      {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   @@FractionLoop  {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}

@@Exponent:

  or    bl,$20

  cmp   bl,'e'-'0'

  jne   @@Error         {Not 'e' or 'E'}

@@GetExponent:

  movzx ebx,byte ptr [esi]  {Get Next Char}

  inc   esi

  mov   cl,0            {Clear Exponent Sign Flag}

  cmp   bl,'-'

  je    @@MinusExp

  cmp   bl,'+'

  je    @@ExpSignSet

  jmp   @@ExpLoop

@@MinusExp:

  mov   cl,1            {Set Exponent Sign Flag}

@@ExpSignSet:

  movzx ebx,byte ptr [esi]   {Get Next Char}

  inc   esi

@@ExpLoop:

  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   @@ExpLoop       {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    @@PowerDone     {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}

@@PowerDone:

  test  ch,ch           {Decimal Sign Flag Set?}

  jnz   @@Negate        {Yes,Negate Value}

@@Success:

  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   @@Success

@@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}



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 and $80=0 then

      inc(P) else begin

      if result and $20=0  then begin

        result := result shl 6+byte(P[1])-$3080; // fast direct process $0..$7ff

        inc(P,2);

      end else

        result := GetHighUTF8UCS4(P); // handle even surrogates

    end;

  end else

    result := 0;

end;



function ContainsUTF8(p, up: PUTF8Char): boolean;

var u: PByte;

begin

  if (p<>nil) and (up<>nil) and (up^<>#0) then begin

    result := true;

    repeat

      u := pointer(up);

      repeat

        if GetNextUTF8Upper(p)<>u^ then

          break else

          inc(u);

        if u^=0 then

          exit; // up^ was found inside p^

      until false;

      p := FindNextUTF8WordBegin(p);

    until p=nil;

  end;

  result := false;

end;



function IdemFileExt(p: PUTF8Char; extup: PAnsiChar; sepChar: AnsiChar): Boolean;

var ext: PUTF8Char;

begin

  if (p<>nil) and (extup<>nil) then begin

    ext := nil;

    repeat

      if p^=sepChar then

        ext := p; // get last '.' position from p into ext

      inc(p);

    until p^=#0;

    if ext<>nil then

      result := IdemPChar(ext,extup) else

      result := false;

  end else

    result := false;

end;



function IdemPCharWithoutWhiteSpace(p: PUTF8Char; up: PAnsiChar): boolean;

begin

  result := False;

  if p=nil then

    exit;

  if up<>nil then

    while up^<>#0 do begin

      while p<=' ' do // trim white space

        if p^=#0 then

          exit else

        inc(p);

      if up^<>NormToUpperAnsi7[p^] then

        exit;

      inc(up);

      inc(p);

    end;

  result := true;

end;



{$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)

begin

  result := false;

  if p=nil then

    exit;

  if (up<>nil) and (up^<>#0) then

    repeat

      if up^<>NormToUpperAnsi7[p^] then

        exit;

      inc(up);

      inc(p);

    until up^=#0;

  result := true;

end;

{$else}

function IdemPChar(p: PUTF8Char; up: PAnsiChar): boolean;

// if the beginning of p^ is same as up^ (ignore case - up^ must be already Upper)

// eax=p edx=up

asm

    test eax,eax

    jz @e // P=nil -> false

    test edx,edx

    push ebx

    jz @t // up=nil -> true

    mov ecx,[edx] // cl=up^[0]

    test cl,cl

    movzx ebx,byte ptr [eax] // bl=p^[0]

    jz @t

    cmp cl,byte ptr [ebx+NormToUpperAnsi7] // bl=NormToUpperAnsi7[p^[0]]

    jnz @f // quick return in case of first invalid char

    lea eax,[eax+1]

    lea edx,[edx+1]

    shr ecx,8 // cl=up^[1], ch=up^[2]

@1: mov bl,[eax] // bl=p^[0]

    test cl,cl

    jz @t // up^[0]=#0 -> OK

    cmp cl,byte ptr [ebx+NormToUpperAnsi7] // bl=NormToUpperAnsi7[p^[0]]

    mov bl,[eax+1] // bl=p^[1]

    lea eax,[eax+2]

    lea edx,[edx+2]

    jne @f

    test ch,ch

    jz @t // up^[1]=#0 -> OK

    cmp ch,byte ptr [ebx+NormToUpperAnsi7] // bl=NormToUpperAnsi7[p^[1]]

    mov ecx,[edx] // cl=up^[0] ch=up^[1]

    je @1

@f: pop ebx // NormToUpperAnsi7[p^]<>up^ -> FALSE

@e: xor eax,eax

    ret

@t: pop ebx // up^=#0 -> TRUE

    mov al,1

end;

{$endif}



function IdemPCharArray(p: PUTF8Char; const upArray: array of PAnsiChar): 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 high(upArray) do

      if (PWord(upArray[result])^=w) and IdemPChar(p+2,upArray[result]+2) 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 UpperCopy255(dest: PAnsiChar; const source: RawUTF8): PAnsiChar;

begin

  if source<>'' then

    result := UpperCopy255Buf(dest,pointer(source),

      {$ifdef HASINLINE}length(source){$else}PInteger(PtrInt(source)-4)^{$endif}) else

    result := dest;

end;



function UpperCopy255BufPas(dest: PAnsiChar; source: PUTF8Char; sourceLen: integer): PAnsiChar;

var i: integer;

    c,d: 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

    for i := 0 to sourceLen shr 3 do begin

      c := PPtrUIntArray(source)^[i];

      d := c or $8080808080808080;

      PPtrUIntArray(dest)^[i] :=

        c-((d-$6161616161616161) and not(d-$7b7b7b7b7b7b7b7b)) and

        ((not c) and $8080808080808080)shr 2;

    end;

    {$else}       // unbranched uppercase conversion of 4 chars blocks

    for i := 0 to sourceLen shr 2 do begin

      c := PPtrUIntArray(source)^[i];

      d := c or $80808080;

      PPtrUIntArray(dest)^[i] := c-((d-$61616161) and not(d-$7b7b7b7b)) and

        ((not c) and $80808080)shr 2;

    end;

    {$endif}

    result := dest+sourceLen; // but we always return the exact size

  end else

    result := dest;

end;



{$ifndef PUREPASCAL}

{$ifndef DELPHI5OROLDER}



const

  CMP_RANGES = $44; // see https://msdn.microsoft.com/en-us/library/bb531425



function UpperCopy255BufSSE42(dest: PAnsiChar; source: PUTF8Char; sourceLen: integer): PAnsiChar;

asm // eax=dest edx=source ecx=sourceLen

       test    ecx,ecx

       jz      @z

       cmp     ecx,16

       movdqu  xmm1,dqword ptr [@az]

       movdqu  xmm3,dqword ptr [@bits]

       ja      @big

       // optimize the common case of sourceLen<=16

       movdqu  xmm2,[edx]

       {$ifdef HASAESNI}

       pcmpistrm xmm1,xmm2,CMP_RANGES // find in range a-z, return mask in xmm0

       {$else}

       db $66,$0F,$3A,$62,$CA,CMP_RANGES

       {$endif}

       pand    xmm0,xmm3

       pxor    xmm2,xmm0

       movdqu  [eax],xmm2

       add     eax,ecx

@z:    ret

@big:  cmp     ecx,240

       push    eax

       jb      @ok

       mov     ecx,239

@ok:   add     [esp],ecx // save to return end position with the exact size

       shr     ecx,4

       sub     edx,eax

       inc     ecx

@s:    movdqu  xmm2,[edx+eax]

       {$ifdef HASAESNI}

       pcmpistrm xmm1,xmm2,CMP_RANGES

       {$else}

       db $66,$0F,$3A,$62,$CA,CMP_RANGES

       {$endif}

       pand    xmm0,xmm3

       pxor    xmm2,xmm0

       movdqu  [eax],xmm2

       dec     ecx

       lea     eax,[eax+16]

       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}

{$endif PUREPASCAL}



function UpperCopyWin255(dest: PWinAnsiChar; const source: RawUTF8): PWinAnsiChar;

var i, L: integer;

begin

  L := PStrRec(Pointer(PtrInt(source)-STRRECSIZE))^.length;

  if L>0 then begin

    if L>250 then

      L := 250; // avoid buffer overflow

    result := dest+L;

    for i := 0 to L-1 do

      dest[i] := AnsiChar(NormToUpperByte[PByteArray(source)[i]]);

  end else

    result := dest;

end;



function UTF8UpperCopy(Dest, Source: PUTF8Char; SourceChars: Cardinal): PUTF8Char;

var c: cardinal;

    endSource, endSourceBy4, S: PUTF8Char;

    extra,i: integer;

label By1, By4, set1; // ugly but faster

begin

  if (Source<>nil) and (Dest<>nil) then begin

    // first handle trailing 7 bit ASCII chars, by quad (Sha optimization)

    endSource := Source+SourceChars;

    endSourceBy4 := endSource-4;

    if (PtrUInt(Source) and 3=0) and (Source<=endSourceBy4) then

    repeat

  By4:c := PCardinal(Source)^;

      if c and $80808080<>0 then

        goto By1; // break on first non ASCII quad

      inc(Source,4);

      Dest[0] := AnsiChar(NormToUpperByte[c and $ff]);

      Dest[1] := AnsiChar(NormToUpperByte[(c shr 8) and $ff]);

      Dest[2] := AnsiChar(NormToUpperByte[(c shr 16) and $ff]);

      Dest[3] := AnsiChar(NormToUpperByte[c shr 24]);

      inc(Dest,4);

    until Source>endSourceBy4;

    // generic loop, handling one UCS4 char per iteration

    if Source<endSource then

    repeat

  By1:c := byte(Source^);

      inc(Source);

      if ord(c) and $80=0 then begin

        Dest^ := AnsiChar(NormToUpperByte[c]);

Set1:   inc(Dest);

        if (PtrUInt(Source) and 3=0) and (Source<EndSourceBy4) then goto By4 else

        if Source<endSource then continue else break;

      end else begin

        extra := UTF8_EXTRABYTES[c];

        if (extra=0) or (Source+extra>endSource) 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 c<minimum then

            break; // invalid input content

        end;

        if (c<=255) and (NormToUpperByte[c]<=127) then begin

          Dest^ := AnsiChar(NormToUpperByte[c]);

          inc(Source,extra);

          goto set1;

        end;

        S := Source-1; // leave UTF-8 encoding untouched

        inc(Source,extra);

        inc(extra);

        MoveFast(S^,Dest^,extra);

        inc(Dest,extra);

        if (PtrUInt(Source) and 3=0) and (Source<EndSourceBy4) then goto By4 else

        if Source<endSource then continue else break;

      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;





{$ifdef PUREPASCAL}

function UpperCopy(dest: PAnsiChar; const source: RawUTF8): PAnsiChar;

var s: PAnsiChar;

    c: cardinal;

begin

  s := pointer(source);

  if s<>nil then

    repeat

      c := ord(s^);

      if c=0 then

        break else

        dest^ := AnsiChar(NormToUpperAnsi7Byte[c]);

      inc(s);

      inc(dest);

    until false;

  result := dest;

end;

{$else}

function UpperCopy(dest: PAnsiChar; const source: RawUTF8): PAnsiChar;

asm // eax=dest source=edx

    test edx,edx

    jz @z

    push esi

    mov esi,offset NormToUpperAnsi7

    xor ecx,ecx

@1: mov cl,[edx]

    inc edx

    test cl,cl

    mov cl,[esi+ecx]

    jz @2

    mov [eax],cl

    inc eax

    jmp @1

@2: pop esi

@z:

end;

{$endif}



{$ifdef PUREPASCAL}

function UpperCopyShort(dest: PAnsiChar; const source: shortstring): PAnsiChar;

var i: PtrInt;

begin

  for i := 1 to ord(source[0]) do begin

    dest^ := AnsiChar(NormToUpperAnsi7Byte[ord(source[i])]);

    inc(dest);

  end;

  result := dest;

end;

{$else}

function UpperCopyShort(dest: PAnsiChar; const source: shortstring): PAnsiChar;

asm // eax=dest source=edx

    push esi

    push ebx

    movzx ebx,byte ptr [edx] // ebx = length(source)

    xor ecx,ecx

    test ebx,ebx

    mov esi,offset NormToUpperAnsi7

    jz @2 // source=''

    inc edx

@1: mov cl,[edx]

    inc edx

    dec ebx

    mov cl,[esi+ecx]

    mov [eax],cl

    lea eax,[eax+1]

    jnz @1

@2: pop ebx

    pop esi

@z:

end;

{$endif}



function GetNextLine(source: PUTF8Char; out next: PUTF8Char): RawUTF8;

begin

  next := source;

  if source=nil then begin

    result := '';

    exit;

  end;

  while source^ in ANSICHARNOT01310 do inc(source);

  SetString(result,PAnsiChar(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;



{$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}



function IdemPCharAndGetNextLine(var source: PUTF8Char; searchUp: PAnsiChar): boolean;

{$ifdef PUREPASCAL}

begin

  if source=nil then

    result := false else begin

    result := IdemPChar(source,searchUp);

    while source^ in ANSICHARNOT01310 do inc(source);

    while source^ in [#13,#10] do inc(source);

    if source^=#0 then

      source := nil;

  end;

end;

{$else}

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;

{$endif}



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));

      Item := GetNextItem(source,Sep);

    end;

  end;

end;



function GetNextLineBegin(source: PUTF8Char; out next: PUTF8Char): PUTF8Char;

begin

  result := pointer(source);

  if source=nil then

    exit;

  while source^ in ANSICHARNOT01310 do inc(source);

  if source^=#13 then inc(source);

  if source^=#10 then inc(source);

  if source^=#0 then

    next := nil else

    next := source;

end;



function GetLineSize(P,PEnd: PUTF8Char): PtrUInt;

begin

  result := PtrUInt(P);

  if P<>nil then

    if PEnd=nil then

      while P^ in ANSICHARNOT01310 do

        inc(P) else

      while (P<PEnd) and (P^ in ANSICHARNOT01310) do

        inc(P);

  result := PtrUInt(P)-result;

end;



function GetNextItem(var P: PUTF8Char; Sep: AnsiChar= ','): RawUTF8;

var S: PUTF8Char;

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 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=#13#10);

var Caption: string;

    i, bool: integer;

    P: PChar;

    first: Boolean;

begin

  P := pointer(CSV);

  if P=nil then

    exit;

  first := True;

  for i := 0 to high(Values) do begin

    Caption := GetNextItemString(P);

    if Values[i]<>'' then begin

      if first then begin

        Result := Result+#13#10;

        first := false;

      end else

        Result := Result+AppendBefore;

      bool := FindCSVIndex('0,-1',RawUTF8(Values[i]));

      Result := Result+Caption+': ';

      if bool<0 then

        Result := Result+Values[i] else

        Result := Result+GetCSVItemString(pointer(GetNextItemString(P)),bool,'/');

    end;

  end;

end;



procedure GetNextItemShortString(var P: PUTF8Char; out Dest: ShortString; Sep: AnsiChar= ',');

var S: PUTF8Char;

    len: integer;

begin

  if P=nil then

    Dest[0] := #0 else begin

    if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

    S := P;

    while (S^<>#0) and (S^<>Sep) do

      inc(S);

    len := S-P;

    while (P[len-1] in [#1..' ']) and (len>0) do dec(len); // trim right spaces

    SetString(Dest,P,len);

    if S^<>#0 then

      P := S+1 else

      P := nil;

  end;

end;



function GetNextItemCardinal(var P: PUTF8Char; Sep: AnsiChar= ','): 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;

  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 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)='?,?,?'

  if Count=0 then begin

    result := '';

    exit;

  end;

  ValueLen := length(Value);

  SepLen := Length(Sep);

  Setlength(result,ValueLen*Count+SepLen*pred(Count));

  P := pointer(result);

  i := 1;

  repeat

    MoveFast(Pointer(Value)^,P^,ValueLen);

    inc(P,ValueLen);

    if i=Count then

      break;

    MoveFast(Pointer(Sep)^,P^,SepLen);

    inc(P,SepLen);

    inc(i);

  until false;

  assert(P-pointer(result)=length(result));

end;



procedure SetBitCSV(var Bits; BitsCount: integer; var P: PUTF8Char);

var bit,last: cardinal;

begin

  while P<>nil do begin

    bit := GetNextItemCardinalStrict(P)-1; // '0' marks end of list

    if bit>=cardinal(BitsCount) then

      break; // avoid GPF

    if (P=nil) or (P^=',') then

      SetBit(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

        SetBit(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 GetBit(Bits,i) then begin

    j := i;

    while (j+1<BitsCount) and GetBit(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^ in ['+','-']) then begin

    minus := P^='-';

    inc(P);

  end else

    minus := false;

  result := PtrInt(GetNextItemCardinal(P,Sep));

  if minus then

    result := -result;

end;



function GetNextItemInt64(var P: PUTF8Char; Sep: AnsiChar= ','): Int64;

{$ifdef CPU64}

begin

  result := GetNextItemInteger(P,Sep);

end;

{$else}

var tmp: array[0..63] of AnsiChar;

    i: integer;

begin

  result := 0;

  if P=nil then

    exit;

  i := 0;

  while (P[i]<>#0) and (P[i]<>Sep) do begin

    tmp[i] := P[i];

    inc(i);

    if i>=sizeof(tmp) then

      exit;

  end;

  tmp[i] := #0;

  inc(P,i); // P[i]=Sep or #0

  if P^=#0 then

    P := nil else

    inc(P);

  SetInt64(tmp,result);

end;

{$endif}



function GetNextItemDouble(var P: PUTF8Char; Sep: AnsiChar= ','): double;

var tmp: array[0..63] of AnsiChar;

    i,err: integer;

begin

  result := 0;

  if P=nil then

    exit;

  i := 0;

  while (P[i]<>#0) and (P[i]<>Sep) do begin

    tmp[i] := P[i];

    inc(i);

    if i>=sizeof(tmp) then

      exit;

  end;

  tmp[i] := #0;

  inc(P,i); // P[i]=Sep or #0

  if P^=#0 then

    P := nil else

    inc(P);

  result := GetExtended(tmp,err);

  if err<>0 then

    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

      result := GetNextItem(P,Sep);

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

    s := GetNextItem(CSV,Sep);

    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);

var s: RawUTF8;

begin

  while CSV<>nil do begin

    s := GetNextItem(CSV,Sep);

    if s<>'' then begin

      SetLength(Result,length(Result)+1);

      Result[high(Result)] := s;

    end;

  end;

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

  result := GetNextItem(CSV,Sep);

  if result='' then

    exit;

  result := Prefix+result;

  while CSV<>nil do begin

    s := GetNextItem(CSV,Sep);

    if s<>'' then

      result := result+','+Prefix+s;

  end;

end;



function RawUTF8ArrayToCSV(const Values: array of RawUTF8; const Sep: RawUTF8 = ','): RawUTF8;

var i, len, seplen, L: Integer;

    P: PAnsiChar;

begin

  result := '';

  if high(Values)<0 then

    exit;

  seplen := length(Sep);

  len := seplen*high(Values);

  for i := 0 to high(Values) do

    inc(len,length(Values[i]));

  SetLength(result,len);

  P := pointer(result);

  i := 0;

  repeat

    L := length(Values[i]);

    if L>0 then begin

      MoveFast(pointer(Values[i])^,P^,L);

      inc(P,L);

    end;

    if i=high(Values) then

      Break;

    if seplen>0 then begin

      MoveFast(pointer(Sep)^,P^,seplen);

      inc(P,seplen);

    end;

    inc(i);

  until false;

  Assert(P-pointer(result)=len);

end;



function RawUTF8ArrayToQuotedCSV(const Values: array of RawUTF8; const Sep: RawUTF8=',';

  Quote: AnsiChar=''''): RawUTF8;

var i: integer;

    tmp: TRawUTF8DynArray;

begin

  SetLength(tmp,length(Values));

  for i := 0 to High(Values) do

    tmp[i] := QuotedStr(Values[i],Quote);

  result := RawUTF8ArrayToCSV(tmp,Sep);

end;



function TRawUTF8DynArrayFrom(const Values: array of RawUTF8): TRawUTF8DynArray;

var i: integer;

begin

  SetLength(result,length(Values));

  for i := 0 to high(Values) do

    result[i] := Values[i];

end;



procedure AddArrayOfConst(var Dest: TTVarRecDynArray; const Values: array of const);

var i,n: Integer;

begin

  n := length(Dest);

  SetLength(Dest,n+length(Values));

  for i := 0 to high(Values) do

    Dest[i+n] := Values[i];

end;



var

  DefaultTextWriterJSONClass: TTextWriterClass = TTextWriter;

  DefaultTextWriterTrimEnum: boolean;



function ObjectToJSON(Value: TObject; Options: TTextWriterWriteObjectOptions): RawUTF8;

begin

  if Value=nil then

    result := 'null' else

    with DefaultTextWriterJSONClass.CreateOwnedStream do

    try

      include(fCustomOptions,twoForceJSONStandard);

      WriteObject(Value,Options);

      SetText(result);

    finally

      Free;

    end;

end;



function ObjectsToJSON(const Names: array of RawUTF8; const Values: array of TObject;

  Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]): RawUTF8;

var i,n: integer;

begin

  with DefaultTextWriterJSONClass.CreateOwnedStream do

  try

    n := length(Names);

    Add('{');

    for i := 0 to high(Values) do

    if Values[i]<>nil then begin

      if i<n then

        AddFieldName(Names[i]) else

        AddPropName(PShortString(PPointer(PPtrInt(Values[i])^+vmtClassName)^)^);

      WriteObject(Values[i],Options);

      Add(',');

    end;

    CancelLastComma;

    Add('}');

    SetText(result);

  finally

    Free;

  end;

end;



function UrlEncode(const svar: RawUTF8): RawUTF8;

begin

  result := UrlEncode(pointer(svar));

end;



function UrlEncode(Text: PUTF8Char): RawUTF8;

function Enc(s, p: PUTF8Char): PUTF8Char;

var c: PtrInt;

begin

  repeat

    c := ord(s^);

    case c of

    0: break;

    ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z'),

    ord('_'),ord('-'),ord('.'),ord('~'): begin

      // cf. rfc3986 2.3. Unreserved Characters

      p^ := AnsiChar(c);

      inc(p);

      inc(s);

      continue;

    end;

    ord(' '): p^ := '+';

    else begin

      p^ := '%'; inc(p);

      PWord(p)^ := TwoDigitsHexWB[c]; inc(p);

    end;

    end; // case c of

    inc(p);

    inc(s);

  until false;

  result := p;

end;

function Size(s: PUTF8Char): PtrInt;

begin

  result := 0;

  if s<>nil then

  repeat

    case s^ of

      #0: exit;

      '0'..'9','a'..'z','A'..'Z','_','-','.','~',' ': begin

        inc(result);

        inc(s);

        continue;

      end;

      else inc(result,3);

    end;

    inc(s);

  until false;

end;

begin

  result := '';

  if Text=nil then

    exit;

  SetLength(result,Size(Text)); // reserve exact memory count

  Enc(Text,pointer(result));

end;



function UrlEncode(const NameValuePairs: array of const): RawUTF8;

// (['select','*','where','ID=12','offset',23,'object',aObject]);

var A, n: PtrInt;

    name, value: RawUTF8;

  function Invalid(P: PAnsiChar): boolean;

  begin

    result := true;

    if P<>nil then begin

      repeat // cf. rfc3986 2.3. Unreserved Characters

        if not (P^ in ['a'..'z','A'..'Z','0'..'9','_','.','~']) then

          exit else

          inc(P);

      until P^=#0;

      result := false;

    end;

  end;

begin

  result := '';

  n := high(NameValuePairs);

  if n>0 then begin

    for A := 0 to n shr 1 do begin

      VarRecToUTF8(NameValuePairs[A*2],name);

      if Invalid(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 UrlEncodeJsonObject(const URIName: RawUTF8; ParametersJSON: PUTF8Char;

  const PropNamesToIgnore: array of RawUTF8): RawUTF8;

var i,j, NameLen: integer;

    sep: AnsiChar;

    Params: TNameValuePUTF8CharDynArray;

begin

  if ParametersJSON=nil then

    result := URIName else

    with TTextWriter.CreateOwnedStream do

    try

      AddString(URIName);

      if (JSONDecode(ParametersJSON,Params,true)<>nil) and (Params<>nil) then begin

        sep := '?';

        for i := 0 to High(Params) do begin

          NameLen := StrLen(Params[i].Name);

          for j := 0 to high(PropNamesToIgnore) do

            if IdemPropNameU(PropNamesToIgnore[j],Params[i].Name,NameLen) then begin

              NameLen := 0;

              break;

            end;

          if NameLen=0 then

            continue;

          Add(sep);

          AddNoJSONEscape(Params[i].Name,NameLen);

          Add('=');

          AddString(UrlEncode(Params[i].Value));

          sep := '&';

        end;

      end;

      SetText(result);

    finally

      Free;

    end;

end;



function UrlDecode(const s: RawUTF8; i: PtrInt = 1; len: PtrInt = -1): RawUTF8;

var L: PtrInt;

    P: PUTF8Char;

begin

  result := '';

  if s='' then

    exit;

  L := PStrRec(Pointer(PtrInt(s)-STRRECSIZE))^.length;

  if len<0 then

    len := L;

  if i>L then

    exit;

  dec(i);

  if len=i then

    exit;

  Setlength(result,len-i); // reserve enough space for result

  P := pointer(result);

  while i<len do begin

    case s[i+1] of

      #0:  break; // reached end of s

      '%': if not HexToChar(PAnsiChar(pointer(s))+i+1,P) then

             P^ := s[i+1] else

             inc(i,2); // browsers may not follow the RFC (e.g. encode % as % !)

      '+': P^  := ' ';

    else

      P^ := s[i+1];

    end; // case s[i] of

    inc(i);

    inc(P);

  end;

  Setlength(result,P-pointer(Result)); // fast with FastMM4/SynScaleMM (in-place realloc)

end;



function UrlDecode(U: PUTF8Char): RawUTF8;

var P,Dest: PUTF8Char;

    L: integer;

    tmp: array[byte] of AnsiChar;

begin

  L := StrLen(U);

  if L=0 then begin

    result := '';

    exit;

  end;

  if L>sizeof(tmp) then begin

    SetLength(result,L);

    Dest := pointer(result);

  end else

    Dest := @tmp;

  P := Dest;

  repeat

    case U^ of

      #0:  break; // reached end of URI

      '%': if not HexToChar(PAnsiChar(U+1),P) then

             P^ := U^ else

             inc(U,2); // browsers may not follow the RFC (e.g. encode % as % !)

      '+': P^  := ' ';

    else

      P^ := U^;

    end; // case s[i] of

    inc(U);

    inc(P);

  until false;

  if Dest=@tmp then

    SetString(result,PAnsiChar(@tmp),P-Dest) else

    SetLength(result,P-Dest);

end;



function UrlDecodeNextValue(U: PUTF8Char; out Value: RawUTF8): PUTF8Char;

var Beg,V: PUTF8Char;

    len, i: PtrInt;

begin

  if U<>nil then begin

    // compute resulting length of value

    Beg := U;

    len := 0;

    while (U^<>#0) and (U^<>'&') do begin

      if (U^='%') and HexToCharValid(PAnsiChar(U+1)) then

        inc(U,3) else

        inc(U);

      inc(len);

    end;

    // decode value content

    SetLength(Value,len);

    V := pointer(Value);

    U := Beg;

    for i := 1 to len do

      if (U^='%') and HexToChar(PAnsiChar(U+1),V) then begin

        inc(V);

        inc(U,3);

      end else begin

        if U^='+' then

          V^ := ' ' else

          V^ := U^;

        inc(V);

        inc(U);

      end;

  end;

  result := U;

end;



function UrlDecodeNextName(U: PUTF8Char; out Name: RawUTF8): PUTF8Char;

var Beg, V: PUTF8Char;

    len, i: PtrInt;

begin

  result := nil;

  if U=nil then

    exit;

  // compute resulting length of name

  Beg := U;

  len := 0;

  repeat

    case U^ of

    #0:  exit;

    '=': begin

      result := U+1;

      break;

    end;

    '%': if (U[1]='3') and (U[2] in ['D','d']) then begin

           result := U+3;

           break;  // %3d means = according to the RFC

         end else

         if HexToCharValid(PAnsiChar(U+1)) then

           inc(U,3) else

           inc(U);

    else inc(U);

    end;

    inc(len);

  until false;

  // decode name content

  SetLength(Name,len);

  V := pointer(Name);

  U := Beg;

  for i := 1 to len do

    if (U^='%') and HexToChar(PAnsiChar(U+1),V) then begin

      inc(V);

      inc(U,3);

    end else begin

      if U^='+' then

        V^ := ' ' else

        V^ := U^;

      inc(V);

      inc(U);

    end;

end;



function UrlDecodeNextNameValue(U: PUTF8Char; var Name,Value: RawUTF8): PUTF8Char;

begin

  result := nil;

  if U=nil then

    exit;

  U := UrlDecodeNextName(U,Name);

  if U=nil then

    exit;

  U := UrlDecodeNextValue(U,Value);

  if U^=#0 then

    result := U else

    result := U+1; // jump '&' to let decode the next name=value pair

end;



function UrlDecodeValue(U: PUTF8Char; Upper: PAnsiChar; var Value: RawUTF8;

  Next: PPUTF8Char=nil): 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,Upper) then begin

    result := true;

    inc(U,StrLen(PUTF8Char(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; Upper: PAnsiChar;

  var Value: integer; Next: PPUTF8Char=nil): 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,Upper) then begin

    inc(U,StrLen(PUTF8Char(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; Upper: PAnsiChar;var Value: Cardinal; Next: PPUTF8Char=nil): 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,Upper) then begin

    inc(U,StrLen(PUTF8Char(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; Upper: PAnsiChar;

  var Value: Int64; Next: PPUTF8Char=nil): boolean;

var tmp: RawUTF8;

begin

  result := UrlDecodeValue(U, Upper, tmp, Next);

  if result then

    SetInt64(pointer(tmp),Value);

end;



function UrlDecodeExtended(U: PUTF8Char; Upper: PAnsiChar;

  var Value: TSynExtended; Next: PPUTF8Char=nil): boolean;

var tmp: RawUTF8;

    err: integer;

begin

  result := UrlDecodeValue(U, Upper, tmp, Next);

  if result then begin

    Value := GetExtended(pointer(tmp),err);

    if err<>0 then

      result := false;

  end;

end;



function UrlDecodeDouble(U: PUTF8Char; Upper: PAnsiChar; var Value: double;

  Next: PPUTF8Char=nil): boolean;

var tmp: RawUTF8;

    err: integer;

begin

  result := UrlDecodeValue(U, Upper, tmp, Next);

  if result then begin

    Value := GetExtended(pointer(tmp),err);

    if err<>0 then

      result := false;

  end;

end;



function UrlDecodeNeedParameters(U, CSVNames: PUTF8Char): boolean;

var tmp: array[byte] of AnsiChar;

    L: integer;

    Beg: PUTF8Char;

// UrlDecodeNeedParameters('price=20.45&where=LastName%3D','price,where') will

// return TRUE

begin

  result := (CSVNames=nil);

  if result then

    exit; // no parameter to check -> success

  if U=nil then

    exit; // no input data -> error

  repeat

    L := 0;

    while (CSVNames^<>#0) and (CSVNames^<>',') do begin

      tmp[L] := NormToUpper[CSVNames^];

      if L=high(tmp) then

        exit else // invalid CSV parameter

        inc(L);

      inc(CSVNames);

    end;

    if L=0 then

      exit; // invalid CSV parameter

    PWord(@tmp[L])^ := ord('=');

    Beg := U;

    repeat

      if IdemPChar(U,tmp) then

        break;

      while not(U^ in [#0,'&']) do inc(U);

      if U^=#0 then

        exit else // didn't find tmp in U

        inc(U); // Jump &

    until false;

    U := Beg;

    if CSVNames^=#0 then

      Break else // no more parameter to check

      inc(CSVNames); // jump &

  until false;

  result := true; // all parameters found

end;



function CSVEncode(const NameValuePairs: array of const;

  const KeySeparator, ValueSeparator: RawUTF8): RawUTF8;

var i: integer;

begin

  if length(NameValuePairs)<2 then

    result := '' else

    with DefaultTextWriterJSONClass.CreateOwnedStream 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(PtrUInt(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(PtrUInt(P),4);

  for i := 1 to Length and 3 do // remaining content

    if PByte(P)^<>0 then

      exit else

      inc(PtrUInt(P));

  result := true;

end;



function IsZero(const Values: TRawUTF8DynArray): boolean;

var i: integer;

begin

  result := false;

  for i := 0 to length(Values)-1 do

    if Values[i]<>'' then

      exit;

  result := true;

end;



function IsZero(const Values: TIntegerDynArray): boolean;

var i: integer;

begin

  result := false;

  for i := 0 to length(Values)-1 do

    if Values[i]<>0 then

      exit;

  result := true;

end;



function IsZero(const Values: TInt64DynArray): boolean;

var i: integer;

begin

  result := false;

  for i := 0 to length(Values)-1 do

    if Values[i]<>0 then

      exit;

  result := true;

end;



{$WARNINGS OFF} // yes, we know there will be dead code below: we rely on it ;)



function IsZero(const Fields: TSQLFieldBits): boolean; overload;

begin

  if MAX_SQLFIELDS=64 then

    result := (PInt64(@Fields)^=0) else

  if MAX_SQLFields=128 then

    result := (PInt64Array(@Fields)^[0]=0) and (PInt64Array(@Fields)^[1]=0) else

  if MAX_SQLFields=192 then

    result := (PInt64Array(@Fields)^[0]=0) and (PInt64Array(@Fields)^[1]=0) and

      (PInt64Array(@Fields)^[2]=0) else

  if MAX_SQLFields=256 then

    result := (PInt64Array(@Fields)^[0]=0) and (PInt64Array(@Fields)^[1]=0) and

      (PInt64Array(@Fields)^[2]=0) and (PInt64Array(@Fields)^[3]=0) else

    result := IsZero(@Fields,sizeof(Fields))

end;



function IsEqual(const A,B: TSQLFieldBits): boolean;

begin

  if MAX_SQLFIELDS=64 then

    result := (PInt64(@A)^=PInt64(@B)^) else

  if MAX_SQLFields=128 then

    result := (PInt64Array(@A)^[0]=PInt64Array(@B)^[0]) and

              (PInt64Array(@A)^[1]=PInt64Array(@B)^[1]) else

  if MAX_SQLFields=192 then

    result := (PInt64Array(@A)^[0]=PInt64Array(@B)^[0]) and

              (PInt64Array(@A)^[1]=PInt64Array(@B)^[1]) and

              (PInt64Array(@A)^[2]=PInt64Array(@B)^[2]) else

  if MAX_SQLFields=256 then

    result := (PInt64Array(@A)^[0]=PInt64Array(@B)^[0]) and

              (PInt64Array(@A)^[1]=PInt64Array(@B)^[1]) and

              (PInt64Array(@A)^[2]=PInt64Array(@B)^[2]) and

              (PInt64Array(@A)^[3]=PInt64Array(@B)^[3]) else

    result := CompareMem(@A,@B,sizeof(TSQLFieldBits))

end;



procedure FillZero(var Values: TRawUTF8DynArray);

var i: integer;

begin

  for i := 0 to length(Values)-1 do

    Values[i] := '';

end;



procedure FillZero(var Values: TIntegerDynArray);

begin

  FillCharFast(Values[0],length(Values)*SizeOf(integer),0);

end;



procedure FillZero(var Values: TInt64DynArray); overload;

begin

  FillCharFast(Values[0],length(Values)*SizeOf(Int64),0);

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;



{$WARNINGS ON}



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 Hash32(const Text: RawByteString): cardinal;

begin

  result := Hash32(pointer(Text),length(Text));

end;



function Hash32(Data: pointer; Len: integer): cardinal;

var s1,s2: cardinal;

    i: PtrInt;

begin

  if Data<>nil then begin

    s1 := 0;

    s2 := 0;

    for i := 1 to Len shr 4 do begin // 16 bytes (4 DWORD) by loop - aligned read

      inc(s1,PCardinalArray(Data)^[0]);

      inc(s2,s1);

      inc(s1,PCardinalArray(Data)^[1]);

      inc(s2,s1);

      inc(s1,PCardinalArray(Data)^[2]);

      inc(s2,s1);

      inc(s1,PCardinalArray(Data)^[3]);

      inc(s2,s1);

      inc(PtrUInt(Data),16);

    end;

    for i := 1 to (Len shr 2)and 3 do begin // 4 bytes (DWORD) by loop

      inc(s1,PCardinalArray(Data)^[0]);

      inc(s2,s1);

      inc(PtrUInt(Data),4);

    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;



function GetBit(const Bits; aIndex: PtrInt): boolean;

{$ifdef PUREPASCAL}

begin

{$ifdef CPU64}

  result := PInt64Array(@Bits)^[aIndex shr 6] and (Int64(1) shl (aIndex and 63)) <> 0;

{$else}

  result := PIntegerArray(@Bits)^[aIndex shr 5] and (1 shl (aIndex and 31)) <> 0;

{$endif}

end;

{$else}

asm

  bt [eax],edx // use very fast i386 bit statement

  sbb eax,eax

  and eax,1

end;

{$endif}



function GetAllBits(Bits: Cardinal; BitCount: Integer): boolean;

begin

  if BitCount in [low(ALLBITS_CARDINAL)..high(ALLBITS_CARDINAL)] then

    result := (Bits and ALLBITS_CARDINAL[BitCount])=ALLBITS_CARDINAL[BitCount] else

    result := false;

end;



procedure SetBit(var Bits; aIndex: PtrInt);

{$ifdef PUREPASCAL}

begin

{$ifdef CPU64}

  PInt64Array(@Bits)^[aIndex shr 6] := PInt64Array(@Bits)^[aIndex shr 6]

    or (Int64(1) shl (aIndex and 63));

{$else}

  PIntegerArray(@Bits)^[aIndex shr 5] := PIntegerArray(@Bits)^[aIndex shr 5]

    or (1 shl (aIndex and 31));

{$endif}

end;

{$else}

asm

  bts [eax],edx // use very fast i386 bit statement

end;

{$endif}



procedure UnSetBit(var Bits; aIndex: PtrInt);

{$ifdef PUREPASCAL}

begin

  PIntegerArray(@Bits)^[aIndex shr 5] := PIntegerArray(@Bits)^[aIndex shr 5]

    and not (1 shl (aIndex and 31));

end;

{$else}

asm

  btr [eax],edx // use very fast i386 bit statement

end;

{$endif}



function GetBit64(const Bits; aIndex: PtrInt): boolean;

{$ifdef PUREPASCAL}

begin

  if PtrUInt(aIndex)>63 then

    result := false else

{$ifdef CPU64}

    result := PInt64(@Bits)^ and (Int64(1) shl (aIndex and 63)) <> 0;

{$else}

    result := PIntegerArray(@Bits)^[aIndex shr 5] and (1 shl (aIndex and 31)) <> 0;

{$endif}

end;

{$else}

asm

    cmp edx,64

    jae @z

    bt [eax],edx  // use very fast i386 bit statement

    sbb eax,eax

    and eax,1

    ret

@z: xor eax,eax

end;

{$endif}



procedure SetBit64(var Bits: Int64; aIndex: PtrInt);

{$ifdef PUREPASCAL}

begin

  if PtrUInt(aIndex)<=63 then

{$ifdef CPU64}

    PInt64Array(@Bits)^[aIndex shr 6] := PInt64Array(@Bits)^[aIndex shr 6]

      or (Int64(1) shl (aIndex and 63));

{$else}

    PIntegerArray(@Bits)^[aIndex shr 5] := PIntegerArray(@Bits)^[aIndex shr 5]

      or (1 shl (aIndex and 31));

{$endif}

end;

{$else}

asm

  cmp edx,64

  jae @z

  bts [eax],edx  // use very fast i386 bit statement

@z:

end;

{$endif}



procedure UnSetBit64(var Bits: Int64; aIndex: PtrInt);

{$ifdef PUREPASCAL}

begin

  if PtrUInt(aIndex)<=63 then

{$ifdef CPU64}

    PInt64Array(@Bits)^[aIndex shr 6] := PInt64Array(@Bits)^[aIndex shr 6]

      and not(Int64(1) shl (aIndex and 63));

{$else}

    PIntegerArray(@Bits)^[aIndex shr 5] := PIntegerArray(@Bits)^[aIndex shr 5]

      and not (1 shl (aIndex and 31));

{$endif}

end;

{$else}

asm

  cmp edx,64

  jae @z

  btr [eax],edx // use very fast i386 bit statement

@z:

end;

{$endif}



function GetBitsCount(const Bits; Count: PtrInt): integer;

{$ifdef PUREPASCAL}

begin

  result := 0;

  while Count>0 do begin

    dec(Count);

    if GetBit(Bits,Count) then

      inc(result);

  end;

end;

{$else}

asm

    xor ecx,ecx

@1: test edx,edx

    jz @n

    dec edx

    bt [eax],edx

    adc ecx,0

    jmp @1

@n: mov eax,ecx

end;

{$endif}



procedure OrMemory(Dest,Source: PByteArray; size: integer);

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: integer);

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: integer);

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: integer);

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 fnv32(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;

{$ifdef PUREPASCAL}

var i: integer;

begin

  if buf<>nil then

    for i := 0 to len-1 do

      crc := (crc xor ord(buf[i]))*16777619;

  result := crc;

end;

{$else}

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!

{$endif}



function kr32(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;

{$ifdef PUREPASCAL}

var i: integer;

begin

  for i := 0 to len-1 do

    crc := ord(buf[i])+crc*31;

  result := crc;

end;

{$else}

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

    lea edx,[edx+4]

    mov esi,eax

    movzx edi,bl

    movzx ebp,bh

    shr ebx,16

    shl eax,5

    sub eax,esi

    lea eax,[eax+edi]

    mov esi,eax

    shl eax,5

    sub eax,esi

    lea esi,[eax+ebp]

    lea eax,[eax+ebp]

    movzx edi,bl

    movzx ebx,bh

    shl eax,5

    sub eax,esi

    lea ebp,[eax+edi]

    lea eax,[eax+edi]

    shl eax,5

    sub eax,ebp

    cmp ecx,8

    lea eax,[eax+ebx]

    lea ecx,[ecx-4]

    jae @8

    test ecx,ecx

    jz @z

@s: mov esi,eax

@1: shl eax,5

    movzx ebx,byte ptr [edx]

    lea edx,[edx+1]

    sub eax,esi

    dec ecx

    lea esi,[eax+ebx]

    lea eax,[eax+ebx]

    jnz @1

@z: pop ebp

    pop ebx

    pop esi

    pop edi

end;

{$endif}



{$ifdef CPUINTEL}

type

 TRegisters = record

   eax,ebx,ecx,edx: cardinal;

 end;



{$ifdef CPU64}

procedure GetCPUID(Param: Cardinal; var Registers: TRegisters);

{$ifdef FPC}nostackframe; assembler;

asm

{$else}

asm // ecx=param, rdx=Registers (Linux: edi,rsi)

  .NOFRAME

{$endif FPC}

  {$ifdef win64}

  mov eax,ecx

  mov r9,rdx

  {$else}

  mov eax,edi

  mov r9,rsi

  {$endif win64}

  mov r10,rbx // preserve rbx

  xor ebx,ebx

  xor ecx,ecx

  xor edx,edx

  cpuid

  mov TRegisters(r9).&eax,eax

  mov TRegisters(r9).&ebx,ebx

  mov TRegisters(r9).&ecx,ecx

  mov TRegisters(r9).&edx,edx

  mov rbx,r10

end;



function crc32csse42(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;

{$ifdef FPC}nostackframe; assembler;

asm

{$else}

asm // ecx=crc, rdx=buf, r8=len (Linux: edi,rsi,rdx)

  .NOFRAME

{$endif FPC}

    {$ifdef win64}

    mov eax,ecx

    {$else}

    mov eax,edi

    mov r8,rdx

    mov rdx,rsi

    {$endif win64}

    not eax

    test r8,r8;   jz @0

    test rdx,rdx; jz @0

@7: test rdx,7;   jz @8 // align to 8 bytes boundary

    crc32 eax,byte ptr [rdx]

    inc rdx

    dec r8;     jz @0

    test rdx,7; jnz @7

@8: mov rcx,r8

    shr r8,3

    jz @2

@1: crc32 eax,dword ptr [rdx]

    crc32 eax,dword ptr [rdx+4]

    dec r8

    lea rdx,[rdx+8]

    jnz @1

@2: and rcx,7; jz @0

    cmp rcx,4; jb @4

    crc32 eax,dword ptr [rdx]

    sub rcx,4

    lea rdx,[rdx+4]

    jz @0

@4: crc32 eax,byte ptr [rdx]

    dec rcx; jz @0

    crc32 eax,byte ptr [rdx+1]

    dec rcx; jz @0

    crc32 eax,byte ptr [rdx+2]

@0: not eax

end;

{$endif CPU64}

{$endif CPUINTEL}



function crc32cfast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;

{$ifdef PUREPASCAL}

begin

  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 := crc32ctab[0,ToByte(result xor ord(buf^))] xor (result shr 8);

      dec(len);

      inc(buf);

    until len=0;

    while len>=4 do begin

      result := result xor PCardinal(buf)^;

      inc(buf,4);

      result := crc32ctab[3,ToByte(result)] xor

                crc32ctab[2,ToByte(result shr 8)] xor

                crc32ctab[1,ToByte(result shr 16)] xor

                crc32ctab[0,result shr 24];

      dec(len,4);

    end;

    while len>0 do begin

      result := crc32ctab[0,ToByte(result xor ord(buf^))] xor (result shr 8);

      dec(len);

      inc(buf);

    end;

  end;

  result := not result;

end;

{$else}

// adapted from fast Aleksandr Sharahov version

asm

  test edx, edx

  jz   @ret

  neg  ecx

  jz   @ret

  not eax

  push ebx

@head:

  test dl,3

  jz   @aligned

  movzx ebx, byte [edx]

  inc  edx

  xor  bl, al

  shr  eax, 8

  xor  eax,dword ptr [ebx*4 + crc32ctab]

  inc  ecx

  jnz  @head

  pop  ebx

  not eax

  ret

@ret:

  rep ret

@aligned:

  sub  edx, ecx

  add  ecx, 8

  jg   @bodydone

  push esi

  push edi

  mov  edi, edx

  mov  edx, eax

@bodyloop:

  mov ebx, [edi + ecx - 4]

  xor edx, [edi + ecx - 8]

  movzx esi, bl

  mov eax,dword ptr [esi*4 + crc32ctab + 1024*3]

  movzx esi, bh

  xor eax,dword ptr [esi*4 + crc32ctab + 1024*2]

  shr ebx, 16

  movzx esi, bl

  xor eax,dword ptr [esi*4 + crc32ctab + 1024*1]

  movzx esi, bh

  xor eax,dword ptr [esi*4 + crc32ctab + 1024*0]

  movzx esi, dl

  xor eax,dword ptr [esi*4 + crc32ctab + 1024*7]

  movzx esi, dh

  xor eax,dword ptr [esi*4 + crc32ctab + 1024*6]

  shr edx, 16

  movzx esi, dl

  xor eax,dword ptr [esi*4 + crc32ctab + 1024*5]

  movzx esi, dh

  xor eax,dword ptr [esi*4 + crc32ctab + 1024*4]

  add ecx, 8

  jg  @done

  mov ebx, [edi + ecx - 4]

  xor eax, [edi + ecx - 8]

  movzx esi, bl

  mov edx,dword ptr [esi*4 + crc32ctab + 1024*3]

  movzx esi, bh

  xor edx,dword ptr [esi*4 + crc32ctab + 1024*2]

  shr ebx, 16

  movzx esi, bl

  xor edx,dword ptr [esi*4 + crc32ctab + 1024*1]

  movzx esi, bh

  xor edx,dword ptr [esi*4 + crc32ctab + 1024*0]

  movzx esi, al

  xor edx,dword ptr [esi*4 + crc32ctab + 1024*7]

  movzx esi, ah

  xor edx,dword ptr [esi*4 + crc32ctab + 1024*6]

  shr eax, 16

  movzx esi, al

  xor edx,dword ptr [esi*4 + crc32ctab + 1024*5]

  movzx esi, ah

  xor edx,dword ptr [esi*4 + crc32ctab + 1024*4]

  add ecx, 8

  jle @bodyloop

  mov eax, edx

@done:

  mov edx, edi

  pop edi

  pop esi

@bodydone:

  sub ecx, 8

  jl @tail

  pop ebx

  not eax

  ret

@tail:

  movzx ebx, byte [edx + ecx]

  xor bl,al

  shr eax,8

  xor eax,dword ptr [ebx*4 + crc32ctab]

  inc ecx

  jnz @tail

  pop ebx

  not eax

end;



procedure GetCPUID(Param: Cardinal; var Registers: TRegisters);

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;

asm // eax=crc, edx=buf, ecx=len

    not eax

    test ecx,ecx; jz @0

    test edx,edx; jz @0

@3: test edx,3;   jz @8 // align to 4 bytes boundary

    {$ifdef ISDELPHI2010}

    crc32 dword ptr eax,byte ptr [edx]

    {$else}

    db $F2,$0F,$38,$F0,$02

    {$endif}

    inc edx

    dec ecx;    jz @0

    test edx,3; jnz @3

@8: push ecx

    shr ecx,3

    jz @2

@1: {$ifdef ISDELPHI2010}

    crc32 dword ptr eax,dword ptr [edx]

    crc32 dword ptr eax,dword ptr [edx+4]

    {$else}

    db $F2,$0F,$38,$F1,$02

    db $F2,$0F,$38,$F1,$42,$04

    {$endif}

    dec ecx

    lea edx,[edx+8]

    jnz @1

@2: pop ecx

    and ecx,7

    jz @0

    cmp ecx,4

    jb @4

    {$ifdef ISDELPHI2010}

    crc32 dword ptr eax,dword ptr [edx]

    {$else}

    db $F2,$0F,$38,$F1,$02

    {$endif}

    sub ecx,4

    lea edx,[edx+4]

    jz @0

@4: {$ifdef ISDELPHI2010}

    crc32 dword ptr eax,byte ptr [edx]

    dec ecx; jz @0

    crc32 dword ptr eax,byte ptr [edx+1]

    dec ecx; jz @0

    crc32 dword ptr eax,byte ptr [edx+2]

    {$else}

    db $F2,$0F,$38,$F0,$02

    dec ecx; jz @0

    db $F2,$0F,$38,$F0,$42,$01

    dec ecx; jz @0

    db $F2,$0F,$38,$F0,$42,$02

    {$endif}

@0: not eax

end;

{$endif PUREPASCAL}



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: array[0..3] of cardinal absolute crc;

begin // see http://www.eecs.harvard.edu/~kirsch/pubs/bbbf/esa06.pdf

  assert(sizeof(h)=sizeof(crc));

  h[0] := crc32c(0,buf,len);

  h[1] := crc32c(h[0],buf,len);

  h[2] := h[0]+h[1];

  h[3] := h[0]+2*h[1];

end;



function IsZero(const dig: THash128): boolean;

begin

  {$ifdef CPU64}

  result := (PInt64Array(@dig)^[0]=0) and (PInt64Array(@dig)^[1]=0);

  {$else}

  result := (PCardinalArray(@dig)^[0]=0) and (PCardinalArray(@dig)^[1]=0) and

            (PCardinalArray(@dig)^[2]=0) and (PCardinalArray(@dig)^[3]=0);

  {$endif}

end;



function IsEqual(const A,B: THash128): boolean;

begin

  {$ifdef CPU64}

  result := (PInt64Array(@A)^[0]=PInt64Array(@B)^[0]) and

            (PInt64Array(@A)^[1]=PInt64Array(@B)^[1]);

  {$else}

  result := (PCardinalArray(@A)^[0]=PCardinalArray(@B)^[0]) and

            (PCardinalArray(@A)^[1]=PCardinalArray(@B)^[1]) and

            (PCardinalArray(@A)^[2]=PCardinalArray(@B)^[2]) and

            (PCardinalArray(@A)^[3]=PCardinalArray(@B)^[3]);

  {$endif}

end;



procedure FillZero(out dig: THash128);

begin

  PInt64Array(@dig)^[0] := 0;

  PInt64Array(@dig)^[1] := 0;

end;



procedure crc256c(buf: PAnsiChar; len: cardinal; out crc: THash256);

var h: array[0..7] of cardinal absolute crc;

    i: cardinal;

begin // see http://www.eecs.harvard.edu/~kirsch/pubs/bbbf/esa06.pdf

  assert(sizeof(h)=sizeof(crc));

  h[0] := crc32c(0,buf,len);

  h[1] := crc32c(h[0],buf,len);

  for i := 0 to 5 do

    h[i+2] := h[0]+i*h[1];

end;



function IsZero(const dig: THash256): boolean;

begin

  {$ifdef CPU64}

  result := (PInt64Array(@dig)^[0]=0) and (PInt64Array(@dig)^[1]=0) and

            (PInt64Array(@dig)^[2]=0) and (PInt64Array(@dig)^[3]=0);

  {$else}

  result := (PCardinalArray(@dig)^[0]=0) and (PCardinalArray(@dig)^[1]=0) and

            (PCardinalArray(@dig)^[2]=0) and (PCardinalArray(@dig)^[3]=0) and

            (PCardinalArray(@dig)^[4]=0) and (PCardinalArray(@dig)^[5]=0) and

            (PCardinalArray(@dig)^[6]=0) and (PCardinalArray(@dig)^[7]=0);

  {$endif}

end;



function IsEqual(const A,B: THash256): boolean;

begin

  {$ifdef CPU64}

  result := (PInt64Array(@A)^[0]=PInt64Array(@B)^[0]) and

            (PInt64Array(@A)^[1]=PInt64Array(@B)^[1]) and

            (PInt64Array(@A)^[2]=PInt64Array(@B)^[2]) and

            (PInt64Array(@A)^[3]=PInt64Array(@B)^[3]);

  {$else}

  result := (PCardinalArray(@A)^[0]=PCardinalArray(@B)^[0]) and

            (PCardinalArray(@A)^[1]=PCardinalArray(@B)^[1]) and

            (PCardinalArray(@A)^[2]=PCardinalArray(@B)^[2]) and

            (PCardinalArray(@A)^[3]=PCardinalArray(@B)^[3]) and

            (PCardinalArray(@A)^[4]=PCardinalArray(@B)^[4]) and

            (PCardinalArray(@A)^[5]=PCardinalArray(@B)^[5]) and

            (PCardinalArray(@A)^[6]=PCardinalArray(@B)^[6]) and

            (PCardinalArray(@A)^[7]=PCardinalArray(@B)^[7]);

  {$endif}

end;



procedure FillZero(out dig: THash256);

begin

  PInt64Array(@dig)^[0] := 0;

  PInt64Array(@dig)^[1] := 0;

  PInt64Array(@dig)^[2] := 0;

  PInt64Array(@dig)^[3] := 0;

end;



procedure SymmetricEncrypt(key: cardinal; var data: RawByteString);

var i,len: integer;

    d: PCardinal;

begin

  UniqueString(AnsiString(data));

  len := length(data);

  d := pointer(data);

  key := key xor cardinal(len);

  for i := 0 to (len shr 2)-1 do begin

    key := key xor crc32ctab[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 crc32ctab[0,17 shl i];

end;



function UnixTimeToDateTime(const UnixTime: Int64): TDateTime;

begin

  result := (UnixTime / SecsPerDay + UnixDateDelta);

end;



function DateTimeToUnixTime(const AValue: TDateTime): Int64;

begin

  result := Round((AValue - UnixDateDelta) * SecsPerDay);

end;



function UnixMSTimeToDateTime(const UnixTime: Int64): TDateTime;

begin

  result := (UnixTime / MSecsPerDay + UnixDateDelta);

end;



function DateTimeToUnixMSTime(const AValue: TDateTime): Int64;

begin

  result := Round((AValue - UnixDateDelta) * MSecsPerDay);

end;



function NowUTC: TDateTime;

{$ifdef MSWINDOWS}

var SystemTime: TSystemTime;

    time: TDateTime;

begin

  GetSystemTime(SystemTime);

  with SystemTime do

    if TryEncodeDate(wYear,wMonth,wDay,result) and

       TryEncodeTime(wHour,wMinute,wSecond,wMilliseconds,time) then

      result := result+time else

      result := 0;

end;

{$else}

begin

  Result := GetNowUTC;

end;

{$endif}



function Iso8601ToDateTimePUTF8Char(P: PUTF8Char; L: integer): TDateTime;

var tmp: TDateTime;

begin

  Iso8601ToDateTimePUTF8CharVar(P,L,tmp);

  result := tmp;

end;



function Iso8601CheckAndDecode(P: PUTF8Char; L: integer; var Value: TDateTime): boolean;

// handle 'YYYY-MM-DDThh:mm:ss' or 'YYYY-MM-DD' or 'Thh:mm:ss'

begin

  if P=nil then

    result := false else

    if ((L=9) and (P[0]='T') and (P[3]=':')) or // 'Thh:mm:ss'

       ((L=10) and (P[4]='-') and (P[7]='-')) or // 'YYYY-MM-DD'

       ((L=19) and (P[4]='-') and (P[10]='T')) then begin

        Iso8601ToDateTimePUTF8CharVar(P,L,Value);

        result := Value<>0;

      end else

      result := false;

end;



{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}

type

  unaligned = Double;

{$endif}



function Char2ToByte(P: PUTF8Char; out Value: Cardinal): Boolean;

var B: cardinal;

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: cardinal;

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: cardinal;

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 i: integer;

    B: cardinal;

    Y,M,D, HH,MI,SS: cardinal;

// expect 'YYYYMMDDThhmmss' format but handle also 'YYYY-MM-DDThh:mm:ss'

begin

  unaligned(result) := 0;

  if P=nil then

    exit;

  if L=0 then

    L := StrLen(P);

  if L<4 then

    exit; // we need 'YYYY' at least

  if P[0]='T' then

    dec(P,8) else begin

    B := ConvertHexToBin[ord(P[0])]; // first digit

    if B>9 then exit else Y := B; // fast check '0'..'9'

    for i := 1 to 3 do begin

      B := ConvertHexToBin[ord(P[i])]; // 3 other digits

      if B>9 then exit else Y := Y*10+B;

    end;

    if P[4] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD

    D := 1;

    if L>=6 then begin // YYYYMM

      M := ord(P[4])*10+ord(P[5])-(48+480);

      if (M=0) or (M>12) then exit;

      if P[6] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD

      if L>=8 then begin // YYYYMMDD

        if not(P[8] in [#0,' ','T']) then

          exit; // invalid date format

        D := ord(P[6])*10+ord(P[7])-(48+480);

        if (D=0) or (D>MonthDays[true][M]) then exit; // worse is leap year=true

      end;

    end else

      M := 1;

    if M>2 then // inlined EncodeDate(Y,M,D)

      dec(M,3) else

    if M>0 then begin

      inc(M,9);

      dec(Y);

    end;

    if Y>9999 then

      exit; // avoid integer overflow e.g. if '0000' is an invalid date

    with Div100(Y) do

      unaligned(result) := (146097*YDiv100) shr 2 + (1461*YMod100) shr 2 +

            (153*M+2) div 5+D-693900;

    if L<15 then

      exit; // not enough space to retrieve the time

  end;

  HH := ord(P[9])*10+ord(P[10])-(48+480);

  if HH<24 then begin

    if P[11]=':' then inc(P);

    MI := ord(P[11])*10+ord(P[12])-(48+480);

    if MI<60 then begin

      if P[13]=':' then inc(P);

      SS := ord(P[13])*10+ord(P[14])-(48+480);

      if SS<60 then // inlined EncodeTime()

        result := result+(HH*(MinsPerHour*SecsPerMin*MSecsPerSec)+

                MI*(SecsPerMin*MSecsPerSec)+SS*MSecsPerSec)/MSecsPerDay;

    end;

  end;

end;



function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer=0): TDateTime;

begin

  Iso8601ToTimePUTF8CharVar(P,L,result);

end;



procedure Iso8601ToTimePUTF8CharVar(P: PUTF8Char; L: integer; var result: TDateTime);

var H,MI,SS: cardinal;

begin

  if Iso8601ToTimePUTF8Char(P,L,H,MI,SS) then

    result := (H*(MinsPerHour*SecsPerMin*MSecsPerSec)+

               MI*(SecsPerMin*MSecsPerSec)+SS*MSecsPerSec)/MSecsPerDay else

    result := 0;

end;



function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer; var H,M,S: 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 inc(P); // allow hh:mm:ss

  M := ord(P[2])*10+ord(P[3])-(48+480);

  if P[4]=':' then inc(P); // allow hh:mm:ss

  S := ord(P[4])*10+ord(P[5])-(48+480);

  if (H<24) and (M<60) and (S<60) 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

  Iso8601ToDateTimePUTF8CharVar(pointer(S),length(S),result);

end;



function TimeLogToDateTime(const TimeStamp: TTimeLog): TDateTime;

begin

  result := PTimeLogBits(@TimeStamp)^.ToDateTime;

end;



procedure DateToIso8601PChar(P: PUTF8Char; Expanded: boolean; Y,M,D: cardinal); overload;

// use 'YYYYMMDD' format if not Expanded, 'YYYY-MM-DD' format if Expanded

begin

{$ifdef PUREPASCAL}

  PWord(P  )^ := TwoDigitLookupW[Y div 100];

  PWord(P+2)^ := TwoDigitLookupW[Y mod 100];

{$else}

  YearToPChar(Y,P);

{$endif}

  inc(P,4);

  if Expanded then begin

    P^ := '-';

    inc(P);

  end;

  PWord(P)^ := TwoDigitLookupW[M];

  inc(P,2);

  if Expanded then begin

    P^ := '-';

    inc(P);

  end;

  PWord(P)^ := TwoDigitLookupW[D];

end;



procedure TimeToIso8601PChar(P: PUTF8Char; Expanded: boolean; H,M,S: cardinal;

  FirstChar: AnsiChar = 'T'); overload;

// use Thhmmss format

begin

  if FirstChar<>#0 then begin

    P^ := FirstChar;

    inc(P);

  end;

  PWord(P)^ := TwoDigitLookupW[H];

  inc(P,2);

  if Expanded then begin

    P^ := ':';

    inc(P);

  end;

  PWord(P)^ := TwoDigitLookupW[M];

  inc(P,2);

  if Expanded then begin

    P^ := ':';

    inc(P);

  end;

  PWord(P)^ := TwoDigitLookupW[S];

end;



procedure DateToIso8601PChar(Date: TDateTime; P: PUTF8Char; Expanded: boolean); overload;

// use YYYYMMDD date format

var Y,M,D: word;

begin

  DecodeDate(Date,Y,M,D);

  DateToIso8601PChar(P,Expanded,Y,M,D);

end;



function DateToIso8601Text(Date: TDateTime): RawUTF8;

begin // into 'YYYY-MM-DD' date format

  SetLength(Result,10);

  DateToIso8601PChar(Date,pointer(Result),True);

end;



procedure TimeToIso8601PChar(Time: TDateTime; P: PUTF8Char; Expanded: boolean;

  FirstChar: AnsiChar = 'T'); overload;

// use Thhmmss format

var H,M,S,MS: word;

begin

  DecodeTime(Time,H,M,S,MS);

  TimeToIso8601PChar(P,Expanded,H,M,S,FirstChar);

end;



function DateTimeToIso8601(D: TDateTime; Expanded: boolean;

  FirstChar: AnsiChar='T'): RawUTF8;

// use YYYYMMDDThhmmss format

const ISO8601_LEN: array[boolean,boolean] of integer = ((19,18),(15,14));

var tmp: array[0..31] of AnsiChar;

begin

  if Expanded then begin

    DateToIso8601PChar(D,tmp,true);

    TimeToIso8601PChar(D,@tmp[10],true,FirstChar);

    SetString(result,PAnsiChar(@tmp),ISO8601_LEN[false,FirstChar=#0]);

  end else begin

    DateToIso8601PChar(D,tmp,false);

    TimeToIso8601PChar(D,@tmp[8],false,FirstChar);

    SetString(result,PAnsiChar(@tmp),ISO8601_LEN[true,FirstChar=#0]);

  end;

end;



function DateToIso8601(Date: TDateTime; Expanded: boolean): RawUTF8;

// use YYYYMMDDTdate format

begin

  FastNewRawUTF8(result,8+2*integer(Expanded));

  DateToIso8601PChar(Date,pointer(result),Expanded);

end;



function DateToIso8601(Y,M,D: cardinal; Expanded: boolean): RawUTF8; overload;

// use 'YYYYMMDD' format if not Expanded, 'YYYY-MM-DD' format if Expanded

begin

  FastNewRawUTF8(result,8+2*integer(Expanded));

  DateToIso8601PChar(pointer(result),Expanded,Y,M,D);

end;



function TimeToIso8601(Time: TDateTime; Expanded: boolean; FirstChar: AnsiChar='T'): RawUTF8;

// use Thhmmss format

begin

  FastNewRawUTF8(result,7+2*integer(Expanded));

  TimeToIso8601PChar(Time,pointer(result),Expanded,FirstChar);

end;



function DateTimeToIso8601Text(DT: TDateTime; FirstChar: AnsiChar): RawUTF8;

begin

  DateTimeToIso8601TextVar(DT,FirstChar,result);

end;



procedure DateTimeToIso8601TextVar(DT: TDateTime; FirstChar: AnsiChar; var result: RawUTF8);

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) else

      result := DateTimeToIso8601(DT,true,FirstChar);

end;



procedure DateTimeToIso8601StringVar(DT: TDateTime; FirstChar: AnsiChar; var result: string);

var tmp: RawUTF8;

begin

  DateTimeToIso8601TextVar(DT,FirstChar,tmp);

  Ansi7ToString(Pointer(tmp),length(tmp),result);

end;



procedure DateTimeToIso8601ExpandedPChar(const Value: TDateTime; Dest: PUTF8Char;

  FirstChar: AnsiChar='T');

begin

  if Value<>0 then begin

    if trunc(Value)<>0 then begin

      DateToIso8601PChar(Value,Dest,true);

      inc(Dest,10);

    end;

    if frac(Value)<>0 then begin

      TimeToIso8601PChar(Value,Dest,true,FirstChar);

      inc(Dest,9);

    end;

  end;

  Dest^ := #0;

end;



function Iso8601ToTimeLogPUTF8Char(P: PUTF8Char; L: integer; ContainsNoTime: PBoolean=nil): TTimeLog;

// bits: S=0..5 M=6..11 H=12..16 D=17..21 M=22..25 Y=26..38

// i.e. S<64 M<64 H<32 D<32 M<16 Y<4096: power of 2 -> use fast shl/shr

var V,B: PtrUInt;

    i: integer;

begin

  result := 0;

  if P=nil then

    exit;

  if L=0 then

    L := StrLen(P);

  if L<4 then

    exit; // we need 'YYYY' at least

  if P[0]='T' then

    dec(P,8) else begin // 'YYYY' -> year decode

    V := ConvertHexToBin[ord(P[0])]; if V>9 then exit;

    for i := 1 to 3 do begin

      B := ConvertHexToBin[ord(P[i])]; if B>9 then exit else V := V*10+B; end;

    result := Int64(V) shl 26;  // store YYYY

    if P[4] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD

    if L>=6 then begin // YYYYMM

      V := ord(P[4])*10+ord(P[5])-(48+480+1); // Month 1..12 -> 0..11

      if V<=11 then

        inc(result,V shl 22) else begin

        result := 0;

        exit;

      end;

      if P[6] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD

      if L>=8 then begin  // YYYYMMDD

        V := ord(P[6])*10+ord(P[7])-(48+480+1); // Day 1..31 -> 0..30

        if (V<=30) and(P[8] in [#0,' ','T']) then

          inc(result,V shl 17) else begin

          result := 0;

          exit;

        end;

      end;

    end;

    if L<15 then begin // not enough place to retrieve a time

      if ContainsNoTime<>nil then

        ContainsNoTime^ := true;

      exit;

    end;

  end;

  if ContainsNoTime<>nil then

    ContainsNoTime^ := false;

  B := ord(P[9])*10+ord(P[10])-(48+480);

  if B<=23 then V := B shl 12 else exit;

  if P[11]=':' then inc(P); // allow hh:mm:ss

  B := ord(P[11])*10+ord(P[12])-(48+480);

  if B<=59 then inc(V,B shl 6) else exit;

  if P[13]=':' then inc(P); // allow hh:mm:ss

  B := ord(P[13])*10+ord(P[14])-(48+480);

  if B<=59 then inc(result,PtrUInt(V+B));

end;



function IsIso8601(P: PUTF8Char; L: integer): boolean;

begin

  result := Iso8601ToTimeLogPUTF8Char(P,L)<>0;

end;



function Iso8601ToTimeLog(const S: RawByteString): TTimeLog;

{$ifdef PUREPASCAL}

begin

  result := Iso8601ToTimeLogPUTF8Char(pointer(S),length(S));

end;

{$else}

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;

{$endif}





{ TTimeLogBits }



// bits: S=0..5 M=6..11 H=12..16 D=17..21 M=22..25 Y=26..38

// size: S=6 M=6  H=5  D=5  M=4  Y=12

// i.e. S<64 M<64 H<32 D<32 M<16 Y<4096: power of 2 -> use fast shl/shr



procedure TTimeLogBits.From(Y, M, D, HH, MM, SS: cardinal);

begin

  inc(HH,D shl 5+M shl 10+Y shl 14-(1 shl 5+1 shl 10));

  Value := SS+MM shl 6+Int64(HH) shl 12;

end;



procedure TTimeLogBits.From(P: PUTF8Char; L: integer);

begin

  Value := Iso8601ToTimeLogPUTF8Char(P,L);

end;



procedure TTimeLogBits.Expand(out Date: TSystemTime);

begin

{$ifdef MSWINDOWS}

  Date.wYear := (Value shr (6+6+5+5+4)) and 4095;

  Date.wMonth := 1+(Int64Rec(Value).Lo shr (6+6+5+5)) and 15;

  Date.wDay := 1+(Int64Rec(Value).Lo shr (6+6+5)) and 31;

  Date.wDayOfWeek := 0;

  Date.wHour := (Int64Rec(Value).Lo shr (6+6)) and 31;

  Date.wMinute := (Int64Rec(Value).Lo shr 6) and 63;

  Date.wSecond := Int64Rec(Value).Lo and 63;

{$else}

  Date.Year := (Value shr (6+6+5+5+4)) and 4095;

  Date.Month := 1+(Int64Rec(Value).Lo shr (6+6+5+5)) and 15;

  Date.Day := 1+(Int64Rec(Value).Lo shr (6+6+5)) and 31;

  Date.DayOfWeek := 0;

  Date.Hour := (Int64Rec(Value).Lo shr (6+6)) and 31;

  Date.Minute := (Int64Rec(Value).Lo shr 6) and 63;

  Date.Second := Int64Rec(Value).Lo and 63;

{$endif}

end;



procedure TTimeLogBits.From(const S: RawUTF8);

begin

  Value := Iso8601ToTimeLog(S);

end;



procedure TTimeLogBits.From(FileDate: integer);

begin

{$ifdef MSWINDOWS}

  From(LongRec(FileDate).Hi shr 9+1980,

       LongRec(FileDate).Hi shr 5 and 15,

       LongRec(FileDate).Hi and 31,

       LongRec(FileDate).Lo shr 11,

       LongRec(FileDate).Lo shr 5 and 63,

       LongRec(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=false);

var HH,MM,SS,MS,Y,M,D: word;

    V: cardinal;

begin

  if DateOnly then

    HH := 0 else

    DecodeTime(DateTime,HH,MM,SS,MS);

  DecodeDate(DateTime,Y,M,D);

  V := HH+D shl 5+M shl 10+Y shl 14-(1 shl 5+1 shl 10);

  if DateOnly then

    Value := Int64(V) shl 12 else

    Value := SS+MM shl 6+Int64(V) shl 12;

end;



procedure TTimeLogBits.FromUnixTime(const UnixTime: Int64);

begin

  From(UnixTimeToDateTime(UnixTime));

end;



procedure TTimeLogBits.FromUnixMSTime(const UnixMSTime: Int64);

begin

  From(UnixMSTimeToDateTime(UnixMSTime));

end;



procedure TTimeLogBits.From(const Time: TSystemTime);

var V: cardinal;

begin

  {$ifdef MSWINDOWS}

  V := Time.wHour+Time.wDay shl 5+Time.wMonth shl 10+

    Time.wYear shl 14-(1 shl 5+1 shl 10);

  Value := Time.wSecond+Time.wMinute shl 6+Int64(V) shl 12;

  {$else}

  V := Time.Hour+Time.Day shl 5+Time.Month shl 10+

    Time.Year shl 14-(1 shl 5+1 shl 10);

  Value := Time.Second+Time.Minute shl 6+Int64(V) shl 12;

  {$endif}

end;



var

  UTCTimeCache: TTimeLog;

  UTCTimeTicks: cardinal;



procedure TTimeLogBits.FromUTCTime;

var Ticks: cardinal;

    Now: TSystemTime;

begin

  Ticks := GetTickCount64 shr 8; // 256 ms resolution

  if Ticks=UTCTimeTicks then begin

    Value := UTCTimeCache;

    exit;

  end;

  {$ifdef MSWINDOWS}

  GetSystemTime(Now); // this API is fast enough for our purpose

  {$else}

  GetNowUTCSystem(Now);

  {$endif}

  From(Now);

  UTCTimeCache := Value;

  UTCTimeTicks := Ticks;

end;



procedure TTimeLogBits.FromNow;

var Now: TSystemTime;

begin

  GetLocalTime(Now); // this API is fast enough for our purpose

  From(Now);

end;



function TTimeLogBits.ToTime: TDateTime;

begin

  if Value and (1 shl (6+6+5)-1)=0 then

    result := 0 else

    result := EncodeTime(

       (Int64Rec(Value).Lo shr (6+6)) and 31,

       (Int64Rec(Value).Lo shr 6) and 63,

        Int64Rec(Value).Lo and 63, 0);

end;



function TryEncodeDate(Year, Month, Day: Word; out Date: TDateTime): Boolean;

begin // faster version by AB

  Result := False;

  if (Month<1) or (Month>12) then exit;

  if (Day <= MonthDays[

      ((Year and 3)=0) and ((Year mod 100>0) or (Year mod 400=0))][Month]) and

     (Year>=1) and (Year<10000) and

     (Month<13) and (Day>0) then begin

    if Month>2 then

      dec(Month,3) else

    if (Month>0) then begin

      inc(Month,9);

      dec(Year);

    end

      else exit; // Month <= 0

    with Div100(Year) do

      Date := (146097*YDiv100) shr 2+(1461*YMod100) shr 2+

            (153*Month+2) div 5+Day-693900;

    result := true;

  end;

end;



function TTimeLogBits.ToDate: TDateTime;

var Y: cardinal;

begin

  Y := (Value shr (6+6+5+5+4)) and 4095;

  if (Y=0) or not TryEncodeDate(Y,

       1+(Int64Rec(Value).Lo shr (6+6+5+5)) and 15,

       1+(Int64Rec(Value).Lo shr (6+6+5)) and 31,result) then

    result := 0;

end;



function TTimeLogBits.ToDateTime: TDateTime;

var Y: cardinal;

    Time: TDateTime;

begin

  Y := (Value shr (6+6+5+5+4)) and 4095;

  if (Y=0) or not TryEncodeDate(Y,

       1+(Int64Rec(Value).Lo shr (6+6+5+5)) and 15,

       1+(Int64Rec(Value).Lo shr (6+6+5)) and 31,result) then

    result := 0;

  if (Value and (1 shl (6+6+5)-1)<>0) and TryEncodeTime(

      (Int64Rec(Value).Lo shr (6+6)) and 31,

      (Int64Rec(Value).Lo shr 6) and 63,

      Int64Rec(Value).Lo and 63, 0, Time) then

    result := result+Time;

end;



function TTimeLogBits.Year: Integer;

begin

  result := (Value shr (6+6+5+5+4)) and 4095;

end;



function TTimeLogBits.Month: Integer;

begin

  result := 1+(Int64Rec(Value).Lo shr (6+6+5+5)) and 15;

end;



function TTimeLogBits.Day: Integer;

begin

  result := 1+(Int64Rec(Value).Lo shr (6+6+5)) and 31;

end;



function TTimeLogBits.Hour: Integer;

begin

  result := (Int64Rec(Value).Lo shr (6+6)) and 31;

end;



function TTimeLogBits.Minute: Integer;

begin

  result := (Int64Rec(Value).Lo shr 6) and 63;

end;



function TTimeLogBits.Second: Integer;

begin

  result := Int64Rec(Value).Lo and 63;

end;



function TTimeLogBits.ToUnixTime: Int64;

begin

  result := DateTimeToUnixTime(ToDateTime);

end;



function TTimeLogBits.ToUnixMSTime: Int64;

begin

  result := DateTimeToUnixMSTime(ToDateTime);

end;



function TTimeLogBits.Text(Dest: PUTF8Char; Expanded: boolean; FirstTimeChar: AnsiChar): integer;

begin

  if Value=0 then

    result := 0 else

  if Value and (1 shl (6+6+5)-1)=0 then begin

    // no Time: just convert date

    DateToIso8601PChar(Dest,Expanded,

      (Value shr (6+6+5+5+4)) and 4095,

      1+(Int64Rec(Value).Lo shr (6+6+5+5)) and 15,

      1+(Int64Rec(Value).Lo shr (6+6+5)) and 31);

    if Expanded then

      result := 10 else

      result := 8;

  end else

  if Value shr (6+6+5)=0 then begin

    // no Date: just convert time

    TimeToIso8601PChar(Dest,Expanded,

      (Int64Rec(Value).Lo shr (6+6)) and 31,

      (Int64Rec(Value).Lo shr 6) and 63,

       Int64Rec(Value).Lo and 63, FirstTimeChar);

    if Expanded then

      result := 9 else

      result := 7;

    if FirstTimeChar=#0 then

      dec(result);

  end else begin

    // convert time and date

    DateToIso8601PChar(Dest,Expanded,

      (Value shr (6+6+5+5+4)) and 4095,

      1+(Int64Rec(Value).Lo shr (6+6+5+5)) and 15,

      1+(Int64Rec(Value).Lo shr (6+6+5)) and 31);

    if Expanded then

      inc(Dest,10) else

      inc(Dest,8);

    TimeToIso8601PChar(Dest,Expanded,

      (Int64Rec(Value).Lo shr (6+6)) and 31,

      (Int64Rec(Value).Lo shr 6) and 63,

       Int64Rec(Value).Lo and 63, FirstTimeChar);

    if Expanded then

      result := 15+4 else

      result := 15;

    if FirstTimeChar=#0 then

      dec(result);

  end;

end;



function TTimeLogBits.Text(Expanded: boolean; FirstTimeChar: AnsiChar = 'T'): RawUTF8;

var tmp: array[0..31] of AnsiChar;

begin

  if Value=0 then

    result := '' else

    SetString(result,PAnsiChar(@tmp),Text(tmp,Expanded,FirstTimeChar));

end;



function TTimeLogBits.i18nText: string;

begin

  if Assigned(i18nDateText) then

    result := i18nDateText(Value) else

    result := {$ifdef UNICODE}Ansi7ToString{$endif}(Text(true,' '));

end;



function TimeLogNow: TTimeLog;

begin

  PTimeLogBits(@result)^.FromNow;

end;



function TimeLogNowUTC: TTimeLog;

begin

  PTimeLogBits(@result)^.FromUTCTime;

end;



function NowToString(Expanded: boolean=true; FirstTimeChar: AnsiChar = ' '): RawUTF8;

var I: TTimeLogBits;

begin

  I.FromNow;

  result := I.Text(Expanded,FirstTimeChar);

end;



function NowUTCToString(Expanded: boolean=true; FirstTimeChar: AnsiChar = ' '): RawUTF8;

var I: TTimeLogBits;

begin

  I.FromUTCTime;

  result := I.Text(Expanded,FirstTimeChar);

end;



function DateTimeMSToString(DateTime: TDateTime; Expanded: boolean;

  FirstTimeChar: AnsiChar; UTC: boolean): RawUTF8;

const FMT: array[boolean] of RawUTF8 = ('%%%%%%%%%', '%-%-%%:%:%:%.%%');

      Z: array[boolean] of RawUTF8 = ('', 'Z');

var HH,MM,SS,MS,Y,M,D: word;

begin //  'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format

  if DateTime=0 then begin

    result := '';

    exit;

  end;

  DecodeDate(DateTime,Y,M,D);

  DecodeTime(DateTime,HH,MM,SS,MS);

  FormatUTF8(FMT[Expanded], [UInt4DigitsToShort(Y),UInt2DigitsToShort(M),

    UInt2DigitsToShort(D),FirstTimeChar,UInt2DigitsToShort(HH),UInt2DigitsToShort(MM),

    UInt2DigitsToShort(SS),UInt3DigitsToShort(MS),Z[UTC]], result);

end;



const

  HTML_WEEK_DAYS: array[1..7] of string[3] =

    ('Sun','Mon','Tue','Wed','Thu','Fri','Sat'); {do not localize}

  HTML_MONTH_NAMES: array[1..12] of string[3] =

    ('Jan','Feb','Mar','Apr','May','Jun', 'Jul','Aug','Sep','Oct','Nov','Dec'); {do not localize}



function DateTimeToHTTPDate(UTCDateTime: TDateTime): RawUTF8;

var HH,MM,SS,MS,Y,M,D: word;

begin

  if UTCDateTime=0 then begin

    result := '';

    exit;

  end;

  DecodeDate(UTCDateTime,Y,M,D);

  DecodeTime(UTCDateTime,HH,MM,SS,MS);

  FormatUTF8('%, % % % %:%:% GMT', [HTML_WEEK_DAYS[DayOfWeek(UTCDateTime)],

    UInt2DigitsToShort(D), HTML_MONTH_NAMES[M],UInt4DigitsToShort(Y),

    UInt2DigitsToShort(HH),UInt2DigitsToShort(MM),

    UInt2DigitsToShort(SS)], result);

end;



function TimeToString: RawUTF8;

var I: TTimeLogBits;

begin

  I.FromNow;

  I.Value := I.Value and (1 shl (6+6+5)-1); // keep only time

  result := I.Text(true,' ');

end;



function TimeLogFromFile(const FileName: TFileName): TTimeLog;

var Date: TDateTime;

begin

  Date := FileAgeToDateTime(FileName);

  if Date=0 then

    result := 0 else

    PTimeLogBits(@result)^.From(Date);

end;



function TimeLogFromDateTime(DateTime: TDateTime): TTimeLog;

begin

  PTimeLogBits(@result)^.From(DateTime);

end;





{ TTimeZoneValue }



function TryEncodeDayOfWeekInMonth(AYear, AMonth, ANthDayOfWeek, ADayOfWeek: integer;

  out AValue: TDateTime): Boolean;

var LStartOfMonth, LDay: integer;

begin // adapted from DateUtils

  LStartOfMonth := (DateTimeToTimeStamp(EncodeDate(AYear,AMonth,1)).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 TTimeZoneValue.EncodeForTimeChange(const year: word): TDateTime;

var dow,day: word;

begin

  if wDayOfWeek=0 then

    dow := 7 else // Delphi Sunday = 7

    dow := wDayOfWeek;

  // Encoding the day of change

  day := wDay;

  while not TryEncodeDayOfWeekInMonth(year,wMonth,day,dow,Result) do begin

    // if wDay = 5 then try it and if needed decrement to find the last

    // occurence of the day in this month

    if day=0 then begin

      TryEncodeDayOfWeekInMonth(year,wMonth,1,7,Result);

      break;

    end;

    dec(day);

  end;

  // finally add the time when change is due

  result := result+EncodeTime(wHour,wMinute,wSecond,wMilliseconds);

end;



function TTimeZoneValue.IsZero: boolean;

begin

  result := (PInt64Array(@self)[0]=0) and (PInt64Array(@self)[1]=0);

end;





{ TTimeZoneData }



function TTimeZoneData.GetTziFor(year: integer): PTimeZoneInfo;

var i,last: integer;

begin

  if dyn=nil then

    result := @tzi else

    if year<=dyn[0].year then

      result := @dyn[0].tzi else begin

      last := high(dyn);

      if year>=dyn[last].year then

        result := @dyn[last].tzi else begin

        for i := 1 to last do

          if year<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,djRawUTF8);

end;



constructor TSynTimeZone.CreateDefault;

begin

  Create;

  {$ifdef LVCL}

  LoadFromFile;

  {$else}

  {$ifdef MSWINDOWS}

  LoadFromRegistry;

  {$else}

  LoadFromFile;

  if fZones.Count=0 then

    LoadFromResource; // if no .tz file is available, try from registry

  {$endif}

  {$endif}

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

    GarbageCollectorFreeAndNil(SharedSynTimeZone,TSynTimeZone.CreateDefault);

  result := SharedSynTimeZone;

end;



function TSynTimeZone.SaveToBuffer: RawByteString;

begin

  result := SynLZCompress(fZones.SaveTo);

end;



procedure TSynTimeZone.SaveToFile(const FileName: TFileName);

var FN: TFileName;

begin

  if FileName='' then

    FN := ChangeFileExt(ExeVersion.ProgramFileName,'.tz') else

    FN := FileName;

  FileFromString(SaveToBuffer,FN);

end;



procedure TSynTimeZone.LoadFromBuffer(const Buffer: RawByteString);

begin

  fZones.LoadFrom(pointer(SynLZDecompress(Buffer)));

  fZones.ReHash;

  FreeAndNil(fIds);

  FreeAndNil(fDisplays);

end;



procedure TSynTimeZone.LoadFromFile(const FileName: TFileName);

var FN: TFileName;

begin

  if FileName='' then

    FN := ChangeFileExt(ExeVersion.ProgramFileName,'.tz') else

    FN := FileName;

  LoadFromBuffer(StringFromFile(FN));

end;



procedure TSynTimeZone.LoadFromResource;

var buf: RawByteString;

begin

  ResourceToRawByteString(ClassName,PChar(10),buf);

  if buf<>'' then

    LoadFromBuffer(buf);

end;



{$ifdef MSWINDOWS}

{$ifndef LVCL}

procedure TSynTimeZone.LoadFromRegistry;

const REGKEY = '\Software\Microsoft\Windows NT\CurrentVersion\Time Zones\';

var Reg: TRegistry;

    Keys: TStringList;

    i,first,last,year,n: integer;

    item: TTimeZoneData;

begin

  fZones.Clear;

  Keys := TStringList.Create;

  Reg := TRegistry.Create;

  try

    Reg.RootKey := HKEY_LOCAL_MACHINE;

    if Reg.OpenKeyReadOnly(REGKEY) then

    try

      Reg.GetKeyNames(Keys);

    finally

      Reg.CloseKey;

    end;

    for i := 0 to Keys.Count-1 do begin

      Finalize(item);

      FillcharFast(item.tzi,SizeOf(item.tzi),0);

      if Reg.OpenKeyReadOnly(REGKEY+Keys[i]) then

      try

        StringToUTF8(Keys[i],RawUTF8(item.id));

        StringToUTF8(Reg.ReadString('Display'),item.Display);

        Reg.ReadBinaryData('TZI', item.tzi, SizeOf(item.tzi));

      finally

        Reg.CloseKey;

      end;

      if Reg.OpenKeyReadOnly(REGKEY+Keys[i]+'\Dynamic DST') then

      try

        first := Reg.ReadInteger('FirstEntry');

        last := Reg.ReadInteger('LastEntry');

        n := 0;

        SetLength(item.dyn,last-first+1);

        for year := first to last do

        if Reg.ReadBinaryData(IntToStr(year),item.dyn[n].tzi,

            SizeOf(TTimeZoneInfo))=SizeOf(TTimeZoneInfo) then begin

          item.dyn[n].year := year;

          inc(n);

        end;

        SetLength(item.dyn,n);

      finally

        Reg.CloseKey;

      end;

      fZones.Add(item);

    end;

  finally

    Reg.Free;

    Keys.Free;

  end;

  fZones.ReHash;

  FreeAndNil(fIds);

  FreeAndNil(fDisplays);

end;

{$endif LVCL}

{$endif MSWINDOWS}



function TSynTimeZone.GetDisplay(const TzId: TTimeZoneID): RawUTF8;

var ndx: integer;

begin

  if self=nil then

    ndx := -1 else

    ndx := fZones.FindHashed(TzID);

  if ndx<0 then

    result := '' else

    result := fZone[ndx].display;

end;



function TSynTimeZone.GetBiasForDateTime(const Value: TDateTime;

  const TzId: TTimeZoneID; out Bias: integer; out HaveDaylight: boolean): boolean;

var ndx: integer;

    y,m,d: word;

    tzi: PTimeZoneInfo;

    std,dlt: TDateTime;

begin

  if (self=nil) or (TzId='') then

    ndx := -1 else

    if TzID=fLastZone then

      ndx := fLastIndex else begin

      ndx := fZones.FindHashed(TzID);

      fLastZone := TzID;

      flastIndex := ndx;

    end;

  if ndx<0 then begin

    Bias := 0;

    HaveDayLight := false;

    result := false;

    exit;

  end;

  DecodeDate(Value,y,m,d);

  tzi := fZone[ndx].GetTziFor(y);

  if tzi.change_time_std.IsZero then begin

    HaveDaylight := false;

    Bias := tzi.Bias+tzi.bias_std;

  end else begin

    HaveDaylight := true;

    std := tzi.change_time_std.EncodeForTimeChange(y);

    dlt := tzi.change_time_dlt.EncodeForTimeChange(y);

    if 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;

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);

    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: integer;

begin

  if fIDs=nil then begin

    fIDs := TStringList.Create;

    for i := 0 to high(fZone) do

      fIDs.Add(UTF8ToString(fZone[i].id));

  end;

  result := fIDs;

end;



function TSynTimeZone.Displays: TStrings;

var i: integer;

begin

  if fDisplays=nil then begin

    fDisplays := TStringList.Create;

    for i := 0 to high(fZone) do

      fDisplays.Add(UTF8ToString(fZone[i].Display));

  end;

  result := fDisplays;

end;





procedure AppendToTextFile(aLine: RawUTF8; const aFileName: TFileName);

var F: THandle;

    Old: TFileName;

    Date: array[1..22] of AnsiChar;

    i: integer;

    {$ifdef MSWINDOWS}

    Now: TSystemTime; {$else}

    D: TDateTime;     {$endif}

begin

  if aFileName='' then

    exit;

  F := FileOpen(aFileName,fmOpenWrite);

  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

  if FileSeek64(F,0,soFromEnd)>MAXLOGSIZE 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

  {$ifdef MSWINDOWS}

  GetLocalTime(Now); // windows dedicated function

  DateToIso8601PChar(@Date[3],true,Now.wYear,Now.wMonth,Now.wDay);

  TimeToIso8601PChar(@Date[13],true,Now.wHour,Now.wMinute,Now.wSecond,' ');

  {$else}

  D := Now; // cross platform version

  DateToIso8601PChar(D,@Date[3],true);

  TimeToIso8601PChar(D,@Date[13],true);

  {$endif}

  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;

{$ifdef CPU64}

var a: array[0..1] of Int64 absolute guid1;

    b: array[0..1] of Int64 absolute guid2;

begin

  result := (a[0]=b[0]) and (a[1]=b[1]);

end;

{$else}

var a: array[0..3] of integer absolute guid1;

    b: array[0..3] of integer absolute guid2;

begin // slightly faster implementation than in SysUtils.pas

  {$ifdef HASINLINE}

  result := (a[0]=b[0]) and (a[1]=b[1]) and (a[2]=b[2]) and (a[3]=b[3]);

  {$else}

  if a[0]<>b[0] then

    result := false else

    result := (a[1]=b[1]) and (a[2]=b[2]) and (a[3]=b[3]);

  {$endif}

end;

{$endif}



function IsEqualGUIDArray(const guid: TGUID; const guids: array of TGUID): integer;

begin

  for result := 0 to high(guids) do

    if IsEqualGUID(guid,guids[result]) then

      exit;

  result := -1;

end;



function IsNullGUID(const guid: TGUID): Boolean;

begin

  {$ifdef CPU64}

  result := (PInt64Array(@guid)^[0]=0) and (PInt64Array(@guid)^[1]=0);

  {$else}

  result := (PIntegerArray(@guid)^[0]=0) and (PIntegerArray(@guid)^[1]=0) and

            (PIntegerArray(@guid)^[2]=0) and (PIntegerArray(@guid)^[3]=0);

  {$endif}

end;



function AddGUID(var guids: TGUIDDynArray; const guid: TGUID;

  NoDuplicates: boolean): integer;

begin

  if NoDuplicates then

    for result := 0 to length(guids)-1 do

      if IsEqualGUID(guid,guids[result]) then

        exit;

  result := length(guids);

  SetLength(guids,result+1);

  guids[result] := guid;

end;



function GUIDToText(P: PUTF8Char; guid: PByteArray): PUTF8Char;

var i: integer;

begin // encode as '3F2504E0-4F89-11D3-9A0C-0305E82C3301'

  for i := 3 downto 0 do begin

    PWord(P)^ := TwoDigitsHexWB[guid[i]];

    inc(P,2);

  end;

  inc(PByte(guid),4);

  for i := 1 to 2 do begin

    P[0] := '-';

    PWord(P+1)^ := TwoDigitsHexWB[guid[1]];

    PWord(P+3)^ := TwoDigitsHexWB[guid[0]];

    inc(PByte(guid),2);

    inc(P,5);

  end;

  P[0] := '-';

  PWord(P+1)^ := TwoDigitsHexWB[guid[0]];

  PWord(P+3)^ := TwoDigitsHexWB[guid[1]];

  P[5] := '-';

  inc(PByte(guid),2);

  inc(P,6);

  for i := 0 to 5 do begin

    PWord(P)^ := TwoDigitsHexWB[guid[i]];

    inc(P,2);

  end;

  result := P;

end;



function HexaToByte(P: PUTF8Char; var Dest: byte): boolean; {$ifdef HASINLINE}inline;{$endif}

var B,C: byte;

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(const guid: TGUID): RawUTF8;

var P: PUTF8Char;

begin

  FastNewRawUTF8(result,38);

  P := pointer(result);

  P^ := '{';

  GUIDToText(P+1,@guid)^ := '}';

end;



function GUIDToShort(const guid: TGUID): TGUIDShortString;

begin

  result[0] := #38;

  result[1] := '{';

  result[38] := '}';

  GUIDToText(@result[2],@guid);

end;



function GUIDToString(const 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}

/// get 32-bit value from 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}

{$endif CPU64}

{$ifdef CPU32}

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}



procedure FillRandom(Dest: PCardinalArray; CardinalCount: integer);

var i: integer;

    c: cardinal;

    timenow: Int64;

begin

  c := GetTickCount64+Random(maxInt)+GetCurrentThreadID;

  QueryPerformanceCounter(timenow);

  c := c xor crc32c(c,@timenow,sizeof(timenow));

  for i := 0 to CardinalCount-1 do begin

    c := c xor crc32ctab[0,(c+cardinal(i)) and 1023]

      xor crc32c(c,pointer(Dest),CardinalCount*4);

    {$ifdef CPUINTEL}

    if cfRAND in CpuFeatures then

      c := c xor RdRand32;

    {$endif};

    Dest^[i] := Dest^[i] xor c;

  end;

end;



function RandomGUID: TGUID;

begin

  FillRandom(@result,sizeof(TGUID) shr 2);

end;



procedure RandomGUID(out result: TGUID); overload;

begin

  FillRandom(@result,sizeof(TGUID) shr 2);

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

    FillcharFast(result,sizeof(result),0);

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;

  FillcharFast(result,sizeof(result),0);

end;



function StrCurr64(P: PAnsiChar; const Value: Int64): PAnsiChar;

var c, c10: Int64;

    c64: Int64Rec absolute c;

    Lo: cardinal;

begin

  if Value=0 then begin

    result := P-1;

    result^ := '0';

    exit;

  end;

  if Value<0 then

    c := -Value else

    c := Value;

  if (c64.Hi=0) and (c64.Lo<10000) then begin

    Lo := c64.Lo; // only decimals

    result := P;

  end else begin

    Lo := 10000;

    result := P-1; // reserve space to insert '.'

  end;

  repeat

    if c64.Hi=0 then begin

      result := StrUInt32(result,c64.Lo);

      break;

    end;

    c10 := c div 100;   // one div by two digits

    dec(c,c10*100);     // fast c := c mod 100

    dec(result,2);

    PWord(result)^ := TwoDigitLookupW[c];

    c := c10;

    if c10=0 then break;

  until false;

  if Lo<10000 then begin

    // only decimals -> append left '0.' to '0.000'

    case Lo of

    1..9: begin // append left '0.000'

      dec(result);

      result^ := '0';

      dec(result,2);

      PWord(result)^ := ord('0')+ord('0')shl 8;

    end;

    10..99: begin // append left '0.00'

      dec(result,2);

      PWord(result)^ := ord('0')+ord('0')shl 8;

    end;

    100..999: begin // append left '0.0'

      dec(result);

      result^ := '0';

    end;

    end;

    dec(result,2);

    PWord(result)^ := ord('0')+ord('.')shl 8;

  end else begin

    // insert '.' just before last 4 decimals

    P[-1] := P[-2];

    P[-2] := P[-3];

    P[-3] := P[-4];

    P[-4] := P[-5];

    P[-5] := '.';

  end;

  if Value<0 then begin

    dec(result);

    result^ := '-';

  end;

end;



procedure Curr64ToStr(const Value: Int64; var result: RawUTF8); overload;

var tmp: array[0..31] of AnsiChar;

    P: PAnsiChar;

    Decim, L: Cardinal;

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;

  SetRawUTF8(result,P,L);

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;

  MoveFast(P^,Dest^,result);

end;



function StrToCurr64(P: PUTF8Char; NoDecimal: PBoolean=nil): Int64;

var c: cardinal;

    minus: boolean;

    Dec: cardinal;

begin

  result := 0;

  if P=nil then

    exit;

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  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;

  Int64Rec(result).Lo := c;

  inc(P);

  repeat

    if P^<>'.' then begin

      c := byte(P^)-48;

      if c>9 then

        break;

      {$ifdef CPU64}

      result := result*10;

      {$else}

      result := result shl 3+result+result;

      {$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 CPU64}

  2: result := result*1000;

  3: result := result*100;

  4: result := result*10;

  {$else}

  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;

  {$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

    Spare: integer;

begin

  Spare := V64 mod 100;

  if Spare<>0 then

    dec(V64,Spare);

  result := Value;

end;



function SimpleRoundTo2Digits(Value: Currency): Currency;

var V64: Int64 absolute Value; // to avoid any floating-point precision issues

    Spare: integer;

begin

  Spare := V64 mod 100;

  if Spare<>0 then

    if Spare>50 then

      inc(V64,100-Spare) else

    if Spare<-50 then

      dec(V64,100+Spare) else

      dec(V64,Spare);

  result := Value;

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;

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;

{$ifdef NODELPHIASM}

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;

{$else}

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

    dec cl

    lea edx,[edx+1]

    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}



function UnCamelCase(const S: RawUTF8): RawUTF8; overload;

begin

  result := '';

  if S='' then

    exit;

  SetLength(result,length(S)*2); // max length

  SetLength(result,UnCamelCase(pointer(result),pointer(S)));

end;



function UnCamelCase(D, P: PUTF8Char): integer; overload;

var Space, SpaceBeg, DBeg: PUTF8Char;

    CapitalCount: integer;

    Number: boolean;

label Next;

begin

  Space := D;

  DBeg := D;

  SpaceBeg := D;

  if (D<>nil) and (P<>nil) then // avoid GPF

  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;

  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;

  result := D-DBeg;

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;

  // new TObject.ClassName is UnicodeString (since Delphi 2009) -> inline code

  // with vmtClassName = UTF-8 encoded text stored in a shortstring = -44

  DelphiName := PPointer(PtrInt(C)+vmtClassName)^;

  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;

  SetString(result,PAnsiChar(@DelphiName^[TrimLeft+1]),ord(DelphiName^[0])-TrimLeft);

end;



function GetCaptionFromClass(C: TClass): string;

var tmp: RawUTF8;

    P: PUTF8Char;

begin

  if C=nil then

    result := '' else begin

    tmp := RawUTF8(C.ClassName);

    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;

var PS: PUTF8Char;

    tmp: array[byte] of AnsiChar;

    L: integer;

begin

  PS := pointer(GetEnumName(aTypeInfo,aIndex));

  L := ord(PS^);

  inc(PS);

  while (L>0) and (PS^ in ['a'..'z']) do begin inc(PS); dec(L); end;

  tmp[L] := #0; // GetCaptionFromPCharLen expect

  MoveFast(PS^,tmp,L);

  GetCaptionFromPCharLen(tmp,result);

end;



function CharSetToCodePage(CharSet: integer): cardinal;

begin

  case CharSet of

    SHIFTJIS_CHARSET:   result := 932;

    HANGEUL_CHARSET:    result := 949;

    GB2312_CHARSET:     result := 936;

    HEBREW_CHARSET:     result := 1255;

    ARABIC_CHARSET:     result := 1256;

    GREEK_CHARSET:      result := 1253;

    TURKISH_CHARSET:    result := 1254;

    VIETNAMESE_CHARSET: result := 1258;

    THAI_CHARSET:       result := 874;

    EASTEUROPE_CHARSET: result := 1250;

    RUSSIAN_CHARSET:    result := 1251;

    BALTIC_CHARSET:     result := 1257;

  else result := CODEPAGE_US; // default is ANSI_CHARSET = iso-8859-1 = windows-1252

  end;

end;



function CodePageToCharSet(CodePage: Cardinal): Integer;

begin

  case CodePage of

    932:  result := SHIFTJIS_CHARSET;

    949:  result := HANGEUL_CHARSET;

    936:  result := GB2312_CHARSET;

    1255: result := HEBREW_CHARSET;

    1256: result := ARABIC_CHARSET;

    1253: result := GREEK_CHARSET;

    1254: result := TURKISH_CHARSET;

    1258: result := VIETNAMESE_CHARSET;

    874:  result := THAI_CHARSET;

    1250: result := EASTEUROPE_CHARSET;

    1251: result := RUSSIAN_CHARSET;

    1257: result := BALTIC_CHARSET;

  else result := ANSI_CHARSET; // default is iso-8859-1 = windows-1252

  end;

end;



function GetMimeContentTypeFromBuffer(Content: Pointer; Len: integer;

  const DefaultContentType: RawUTF8): RawUTF8;

begin

  result := DefaultContentType;

  if (Content<>nil) and (Len>4) then

    case PCardinal(Content)^ of

    $04034B50: result := 'application/zip'; // 50 4B 03 04

    $46445025: result := 'application/pdf'; //  25 50 44 46 2D 31 2E

    $21726152: result := 'application/x-rar-compressed'; // 52 61 72 21 1A 07 00

    $AFBC7A37: result := 'application/x-7z-compressed';  // 37 7A BC AF 27 1C

    $75B22630: result := 'audio/x-ms-wma'; // 30 26 B2 75 8E 66

    $9AC6CDD7: result := 'video/x-ms-wmv'; // D7 CD C6 9A 00 00

    $474E5089: result := 'image/png'; // 89 50 4E 47 0D 0A 1A 0A

    $38464947: result := 'image/gif'; // 47 49 46 38

    $46464F77: result := 'application/font-woff'; // wOFF in BigEndian

    $46464952: if Len>16 then // RIFF

      case PCardinalArray(Content)^[2] of

      $50424557: result := 'image/webp';

      $20495641: if PCardinalArray(Content)^[3]=$5453494C then

        result := 'video/x-msvideo'; // Windows Audio Video Interleave file

      end;

    $002A4949, $2A004D4D, $2B004D4D:

      result := 'image/tiff'; // 49 49 2A 00 or 4D 4D 00 2A or 4D 4D 00 2B

    $E011CFD0: // Microsoft Office applications D0 CF 11 E0=DOCFILE

      if Len>600 then

      case PWordArray(Content)^[256] of // at offset 512

        $A5EC: result := 'application/msword'; // EC A5 C1 00

        $FFFD: // FD FF FF

          case PByteArray(Content)^[516] of

            $0E,$1C,$43: result := 'application/vnd.ms-powerpoint';

            $10,$1F,$20,$22,$23,$28,$29: result := 'application/vnd.ms-excel';

          end;

      end;

    $5367674F:

      if Len>14 then // OggS

        if (PCardinalArray(Content)^[1]=$00000200) and

           (PCardinalArray(Content)^[2]=$00000000) and

           (PWordArray(Content)^[6]=$0000) then

          result := 'video/ogg';

    $1C000000:

      if Len>12 then

        if PCardinalArray(Content)^[1]=$70797466 then  // ftyp

          case PCardinalArray(Content)^[2] of

            $6D6F7369, // isom: ISO Base Media file (MPEG-4) v1

            $3234706D: // mp42: MPEG-4 video/QuickTime file

              result := 'video/mp4';

            $35706733: // 3gp5: MPEG-4 video files

              result := 'video/3gpp';

          end;

    else

      case PCardinal(Content)^ and $00ffffff of

        $685A42: result := 'application/bzip2'; // 42 5A 68

        $088B1F: result := 'application/gzip'; // 1F 8B 08

        $492049: result := 'image/tiff'; // 49 20 49

        $FFD8FF: result := 'image/jpeg'; // FF D8 FF DB/E0/E1/E2/E3/E8

        else

          case PWord(Content)^ of

            $4D42: result := 'image/bmp'; // 42 4D

          end;

      end;

    end;

end;

function GetMimeContentType(Content: Pointer; Len: integer;

  const FileName: TFileName=''): RawUTF8;

begin // see http://www.garykessler.net/library/file_sigs.html for magic numbers

  if Content<>nil then

    result := GetMimeContentTypeFromBuffer(Content,Len,'') else

    result := '';

  if (result='') and (FileName<>'') then begin

    result := LowerCase(StringToAnsi7(ExtractFileExt(FileName)));

    case PosEx(copy(result,2,4),

        'png,gif,tiff,jpg,jpeg,bmp,doc,htm,html,css,js,ico,wof,txt,svg,'+

      // 1   5   9    14  18   23  27  31  35   40  44 47  51  55  59

        'atom,rdf,rss,webp,appc,mani,docx,xml,json,woff,ogg,ogv,mp4,m2v,m2p,mp3,h264') of

      // 63   68  72  76   81   86   91   96  100  105  110 114 118 122 126 130 134

      1:  result := 'image/png';

      5:  result := 'image/gif';

      9:  result := 'image/tiff';

      14,18: result := 'image/jpeg';

      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: 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

      else

        if result<>'' then

          result := 'application/'+copy(result,2,10);

    end;

  end;

  if result='' then

    result := BINARY_CONTENT_TYPE;

end;



function GetMimeContentTypeHeader(const Content: RawByteString;

  const FileName: TFileName): RawUTF8;

begin

  result := HEADER_CONTENT_TYPE+

    GetMimeContentType(Pointer(Content),length(Content),FileName);

end;



function IsContentCompressed(Content: Pointer; Len: integer): boolean;

begin

  if (Content<>nil) and (Len>4) then

    case PCardinal(Content)^ of

    $04034B50, // 'application/zip' = 50 4B 03 04

    $21726152, // 'application/x-rar-compressed' = 52 61 72 21 1A 07 00

    $AFBC7A37, // 'application/x-7z-compressed' = 37 7A BC AF 27 1C

    $75B22630, // 'audio/x-ms-wma' = 30 26 B2 75 8E 66

    $9AC6CDD7, // 'video/x-ms-wmv' = D7 CD C6 9A 00 00

    $474E5089, // 'image/png' = 89 50 4E 47 0D 0A 1A 0A

    $38464947, // 'image/gif' = 47 49 46 38

    $46464F77, // 'application/font-woff' = wOFF in BigEndian

    $002A4949, $2A004D4D, $2B004D4D: // 'image/tiff'

      result := true;

    $46464952: if Len>16 then // RIFF

      case PCardinalArray(Content)^[2] of

      $50424557: // 'image/webp'

        result := true;

      else result := False;

      end else

      result := false;

    else

      case PCardinal(Content)^ and $00ffffff of

        $685A42, // 'application/bzip2' = 42 5A 68

        $088B1F, // 'application/gzip' = 1F 8B 08

        $492049, // 'image/tiff' = 49 20 49

        $FFD8FF: // 'image/jpeg' = FF D8 FF DB/E0/E1/E2/E3/E8

          result := true;

        else result := false;

      end;

    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','APPLICATION/JSON','IMAGE/SVG+XML']);

end;



function MultiPartFormDataDecode(const MimeType,Body: RawUTF8;

  var MultiPart: TMultiPartDynArray): boolean;

var boundary,endBoundary: RawUTF8;

    i,j: integer;

    P: PUTF8Char;

    part: TMultiPart;

begin

  result := false;

  i := PosEx('boundary=',MimeType);

  if i=0 then

    exit;

  boundary := trim(copy(MimeType,i+9,200));

  if (boundary<>'') and (boundary[1]='"') then

    boundary := copy(boundary,2,length(boundary)-2); // "boundary" -> boundary

  boundary := '--'+boundary;

  endBoundary := boundary+'--'+#13#10;

  boundary := boundary+#13#10;

  i := PosEx(boundary,Body);

  if i<>0 then

  repeat

    inc(i,length(boundary));

    if i=length(body) then

      exit; // reached the end

    P := PUTF8Char(Pointer(Body))+i-1;

    Finalize(part);

    repeat

      if IdemPChar(P,'CONTENT-DISPOSITION: ') then begin

        inc(P,21);

        if IdemPCharAndGetNextItem(P,'FORM-DATA; NAME="',part.Name,'"') then

          IdemPCharAndGetNextItem(P,'; FILENAME="',part.FileName,'"') else

          IdemPCharAndGetNextItem(P,'FILE; FILENAME="',part.FileName,'"')

      end else

      if not IdemPCharAndGetNextItem(P,'CONTENT-TYPE: ',part.ContentType) then

         IdemPCharAndGetNextItem(P,'CONTENT-TRANSFER-ENCODING: ',part.Encoding);

      GetNextLineBegin(P,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 else

    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;

  procedure NewBound;

  var random: array[1..3] of cardinal;

  begin

    FillRandom(@random,3);

    bound := BinToBase64(@random,sizeof(Random));

    SetLength(boundaries,boundcount+1);

    boundaries[boundcount] := bound;

    inc(boundcount);

  end;

begin

  result := false;

  len := length(MultiPart);

  if len=0 then

    exit;

  boundcount := 0;

  filescount := 0;

  W := TTextWriter.CreateOwnedStream;

  try

    // header multipart

    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'Content-Disposition: form-data; name="%"'#13+

          'Content-Type: %'#13#13'%'#13'--%'#13,

          [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+

            'Content-Type: multipart/mixed; boundary=%'#13#13,[bound]);

        end;

        inc(filescount);

        W.Add('--%'#13'Content-Disposition: file; filename="%"'#13+

          'Content-Type: %'#13,[bound,FileName,ContentType]);

        if Encoding<>'' then

          W.Add('Content-Transfer-Encoding: %'#13,[Encoding]);

        W.AddCR;

        W.AddString(MultiPart[i].Content);

        W.Add(#13'--%'#13,[bound]);

      end;

    end;

    // footer multipart

    for i := boundcount-1 downto 0 do

      W.Add('--%--'#13, [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;

var L,i,cmp: PtrInt;

begin // fast binary search

  if R<0 then

    result := 0 else begin

    L := 0;

    result := -1; // return -1 if found

    repeat

      i := (L + R) shr 1;

      cmp := StrComp(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 (StrComp(P^[i],Value)>=0) do dec(i);

    result := i+1; // return the index where to insert

  end;

end;



function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char;

  Compare: TUTF8Compare): PtrInt; overload;

var L,i,cmp: PtrInt;

begin // fast binary search 

  if not Assigned(Compare) or (R<0) then

    result := 0 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; overload;

var L, cmp: PtrInt;

begin // fast binary search

  L := 0;

  if Assigned(Compare) and (0<=R) then

  repeat

    result := (L + R) shr 1;

    cmp := Compare(P^[result],Value);

    if cmp=0 then

      exit;

    if cmp<0 then

      L := result + 1 else

      R := result - 1;

  until (L > R);

  result := -1;

end;



function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt;

var L, cmp: PtrInt;

begin// fast binary search

  L := 0;

  if 0<=R then

  repeat

    result := (L + R) shr 1;

    cmp := StrComp(P^[result],Value);

    if cmp=0 then

      exit;

    if cmp<0 then

      L := result + 1 else

      R := result - 1;

  until (L > R);

  result := -1;

end;



function FastFindIndexedPUTF8Char(P: PPUTF8CharArray; R: PtrInt;

  var SortedIndexes: TCardinalDynArray; Value: PUTF8Char;

  ItemComp: TUTF8Compare): PtrInt;

var L, cmp: PtrInt;

begin // fast 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

      L := result + 1 else

      R := result - 1;

  until (L > R);

  result := -1;

end;



function AddSortedRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer;

  const Value: RawUTF8; CoValues: PIntegerDynArray=nil; ForcedIndex: PtrInt=-1;

  Compare: TUTF8Compare=nil): PtrInt;

var n: PtrInt;

begin

  if ForcedIndex>=0 then

    result := ForcedIndex else begin

    if Assigned(Compare) then

      result := FastLocatePUTF8CharSorted(pointer(Values),ValuesCount-1,pointer(Value),Compare) else

      result := FastLocatePUTF8CharSorted(pointer(Values),ValuesCount-1,pointer(Value));

    if result<0 then

      exit; // Value exists -> fails

  end;

  n := Length(Values);

  if ValuesCount=n then begin

    inc(n,256+n shr 3);

    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 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 = {$ifndef UNICODE}object{$else}record{$endif}

    Values: PPointerArray;

    Compare: TUTF8Compare;

    CoValues: PIntegerArray;

    Pivot: pointer;

    procedure Sort(L,R: PtrInt);

  end;



procedure TQuickSortRawUTF8.Sort(L, R: PtrInt);

var I, J, P: integer;

    Tmp: Pointer;

    TmpInt: integer;

begin

  if 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

          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 L < J then

      Sort(L, J);

    L := I;

  until I >= R;

end;



procedure QuickSortRawUTF8(var Values: TRawUTF8DynArray; ValuesCount: integer;

  CoValues: PIntegerDynArray=nil; Compare: TUTF8Compare=nil);

var QS: TQuickSortRawUTF8;

begin

  QS.Values := pointer(Values);

  if Assigned(Compare) then

    QS.Compare := Compare else

    QS.Compare := @StrComp;

  if CoValues=nil then

    QS.CoValues := nil else

    QS.CoValues := pointer(CoValues^);

  QS.Sort(0,ValuesCount-1);

end;



function DeleteRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer;

  Index: integer; CoValues: PIntegerDynArray=nil): boolean;

var n: integer;

begin

  n := ValuesCount;

  if Cardinal(Index)>=Cardinal(n) then

    result := false else begin

    dec(n);

    ValuesCount := n;

    Values[Index] := ''; // avoid GPF

    dec(n,Index);

    if n>0 then begin

      if CoValues<>nil then

        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 := '';

  if GetEnumInfo(TypeInfo(TIntelCpuFeature),MaxValue,List) then

    for f := low(f) to high(f) do begin

      if (f in aIntelCPUFeatures) and (List^[3]<>'_') then begin

        if result<>'' then

          result := result+Sep;

        result := result+RawUTF8(copy(List^,3,10));

      end;

      inc(PByte(List),ord(List^[0])+1); // next short string

    end;

end;



function SystemInfoJson: RawUTF8;

begin

  with SystemInfo do

    result := JSONEncode([

      'host',ExeVersion.Host,'user',ExeVersion.User,'os',OSVersionText,

      'cpucount',

      {$ifdef MSWINDOWS}

      dwNumberOfProcessors,{$ifndef CPU64}'wow64',IsWow64,{$endif}

      {$else MSWINDOWS}

      nprocs,

      {$endif MSWINDOWS}

      {$ifndef PUREPASCAL}{$ifdef CPUINTEL}

      'cpufeatures', LowerCase(ToText(CpuFeatures, ' ')),

      {$endif}{$endif}

      'freemem',TSynMonitorMemory.FreeAsText,'freedisk',TSynMonitorDisk.FreeAsText]);

end;



{$ifdef MSWINDOWS}



{$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;





{$else}



const

  _SC_PAGE_SIZE = $1000;



{$endif MSWINDOWS}



{ TFileVersion }



constructor TFileVersion.Create(const aFileName: TFileName;

  aMajor,aMinor,aRelease,aBuild: integer);

var M,D: word;

{$ifdef MSWINDOWS}

    Size, Size2: DWord;

    Pt: Pointer;

    Info: ^TVSFixedFileInfo;

    FileTime: TFILETIME;

    SystemTime: TSYSTEMTIME;

    tmp: TFileName;

{$endif}

begin

  fFileName := aFileName;

  {$ifdef MSWINDOWS}

  if aFileName<>'' then begin

    // GetFileVersionInfo modifies the filename parameter data while parsing.

    // Copy the string const into a local variable to create a writeable copy.

    SetString(tmp,PChar(aFileName),length(aFileName));

    Size := GetFileVersionInfoSize(pointer(tmp), Size2);

    if Size>0 then begin

      GetMem(Pt, Size);

      try

        GetFileVersionInfo(pointer(aFileName), 0, Size, Pt);

        VerQueryValue(Pt, '\', pointer(Info), Size2);

        with Info^ do begin

          if Version32=0 then begin

            aMajor := dwFileVersionMS shr 16;

            aMinor := word(dwFileVersionMS);

            aRelease := dwFileVersionLS shr 16;

          end;

          aBuild := word(dwFileVersionLS);

          BuildYear := 2010;

          if (dwFileDateLS<>0) and (dwFileDateMS<>0) then begin

            FileTime.dwLowDateTime:= dwFileDateLS; // built date from version info

            FileTime.dwHighDateTime:= dwFileDateMS;

            FileTimeToSystemTime(FileTime, SystemTime);

            fBuildDateTime := EncodeDate(

              SystemTime.wYear,SystemTime.wMonth,SystemTime.wDay);

          end;

        end;

      finally

        Freemem(Pt);

      end;

    end;

  end;

  {$endif}

  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.VersionInfo: RawUTF8;

begin

  FormatUTF8('% % %',[ExtractFileName(fFileName),fDetailed,BuildDateTimeString],result);

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 i: integer;

{$ifdef MSWINDOWS}

    Tmp: array[byte] of WideChar;

    TmpSize: cardinal;

{$endif}

begin

  with ExeVersion do begin

    if Version=nil then begin

      {$ifdef MSWINDOWS}

      ProgramFileName := paramstr(0);

      {$else}

      ProgramFileName := GetModuleName(hInstance);

      if ProgramFileName='' then

        ProgramFileName := ExpandFileName(paramstr(0));

      {$endif}

      ProgramFilePath := ExtractFilePath(ProgramFileName);

      if IsLibrary then

        InstanceFileName := GetModuleName(HInstance) else

        InstanceFileName := ProgramFileName;

      ProgramName := StringToUTF8(ExtractFileName(ProgramFileName));

      i := length(ProgramName);

      while i>0 do

        if ProgramName[i]='.' then begin

          SetLength(ProgramName,i-1);

          break;

        end else

        dec(i);

      {$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}

      Host := GetHostName;

      {$ifdef KYLIX3}

      User := LibC.getpwuid(LibC.getuid)^.pw_name;

      {$endif}

      {$endif}

      if Host='' then

        Host := 'unknown';

      if User='' then

        User := 'unknown';

      GarbageCollectorFreeAndNil(Version,

        TFileVersion.Create(InstanceFileName,aMajor,aMinor,aRelease,aBuild));

    end else

      Version.SetVersion(aMajor,aMinor,aRelease,aBuild);

    FormatUTF8('% % (%)',[ProgramFileName,Version.Detailed,

      DateTimeToIso8601(Version.BuildDateTime,True,' ')],ProgramFullSpec);

  end;

end;



{$ifdef DARWIN}

function mprotect(Addr: Pointer; Len: size_t; Prot: Integer): Integer;

  cdecl external 'libc.dylib' name 'mprotect';

  {$define USEMPROTECT}

{$endif}

{$ifdef KYLIX3}

  {$define USEMPROTECT}

{$endif}



procedure PatchCode(Old,New: pointer; Size: integer; Backup: pointer=nil;

  LeaveUnprotected: boolean=false);

{$ifdef MSWINDOWS}

var RestoreProtection, Ignore: DWORD;

    i: integer;

begin

  if VirtualProtect(Old, Size, PAGE_EXECUTE_READWRITE, RestoreProtection) then

  begin

    if Backup<>nil then

      for i := 0 to Size-1 do  // do not use Move() here

        PByteArray(Backup)^[i] := PByteArray(Old)^[i];

    for i := 0 to Size-1 do    // do not use Move() here

      PByteArray(Old)^[i] := PByteArray(New)^[i];

    if not LeaveUnprotected then

      VirtualProtect(Old, Size, RestoreProtection, Ignore);

    FlushInstructionCache(GetCurrentProcess, Old, Size);

    if not CompareMem(Old,New,Size) then

      raise ESynException.Create('PatchCode?');

  end;

end;

{$else}

var PageSize, AlignedAddr: PtrInt;

    i: integer;

begin

  if Backup<>nil then

    for i := 0 to Size-1 do  // do not use Move() here

      PByteArray(Backup)^[i] := PByteArray(Old)^[i];

  PageSize := _SC_PAGE_SIZE;

  AlignedAddr := PtrInt(Old) and not (PageSize - 1);

  while PtrInt(Old) + Size >= AlignedAddr + PageSize do

    Inc(PageSize,_SC_PAGE_SIZE);

  {$ifdef USEMPROTECT}

  if mprotect(Pointer(AlignedAddr),PageSize,PROT_READ or PROT_WRITE or PROT_EXEC)=0 then

  {$else}

  Do_SysCall(syscall_nr_mprotect,PtrUInt(AlignedAddr),PageSize,PROT_READ or PROT_WRITE or PROT_EXEC);

  {$endif}

    try

      for i := 0 to Size-1 do    // do not use Move() here

        PByteArray(Old)^[i] := PByteArray(New)^[i];

    except

    end;

end;

{$endif}



procedure PatchCodePtrUInt(Code: PPtrUInt; Value: PtrUInt;

  LeaveUnprotected: boolean=false);

begin

  PatchCode(Code,@Value,SizeOf(Code^),nil,LeaveUnprotected);

end;



{$ifdef CPUINTEL}



procedure RedirectCode(Func, RedirectFunc: Pointer; Backup: PPatchCode=nil);

var NewJump: packed record

    Code: byte;        // $e9 = jmp {relative}

    Distance: integer; // relative jump is 32 bit even on CPU64

  end;

begin

  if (Func=nil) or (RedirectFunc=nil) then

    exit; // nothing to redirect to

  assert(sizeof(TPatchCode)=sizeof(NewJump));

  NewJump.Code := $e9;

  NewJump.Distance := PtrInt(RedirectFunc)-PtrInt(Func)-sizeof(NewJump);

  PatchCode(Func,@NewJump,sizeof(NewJump),Backup);

  {$ifndef LVCL}

  assert(pByte(Func)^=$e9);

  {$endif}

end;



procedure RedirectCodeRestore(Func: pointer; const Backup: TPatchCode);

begin

  PatchCode(Func,@Backup,sizeof(TPatchCode));

end;



{$endif CPUINTEL}





{$ifndef LVCL}

{$ifndef FPC}

{$ifdef MSWINDOWS}



{ THeapMemoryStream = faster TMemoryStream using FastMM4/SynScaleMM heap,

  not windows.GlobalAlloc() }



const

  MemoryDelta = $8000; // 32 KB granularity (must be a power of 2)



function THeapMemoryStream.Realloc(var NewCapacity: longint): Pointer;

// allocates memory from Delphi heap (FastMM4/SynScaleMM) and not windows.Global*()

// and uses bigger growing size -> a lot faster

var i: PtrInt;

begin

  if NewCapacity>0 then begin

    i := Seek(0,soFromCurrent); // no direct access to fSize -> use Seek() trick

    if NewCapacity=Seek(0,soFromEnd) then begin // avoid ReallocMem() if just truncate

      result := Memory;

      Seek(i,soBeginning);

      exit;

    end;

    NewCapacity := (NewCapacity + (MemoryDelta - 1)) and not (MemoryDelta - 1);

    Seek(i,soBeginning);

  end;

  Result := Memory;

  if NewCapacity <> Capacity then begin

    if NewCapacity = 0 then begin

      FreeMem(Memory);

      Result := nil;

    end else begin

      if Capacity = 0 then

        GetMem(Result, NewCapacity) else

        if NewCapacity > Capacity then // only realloc if necessary (grow up)

          ReallocMem(Result, NewCapacity) else

          NewCapacity := Capacity; // same capacity as before

      if Result = nil then

        raise EStreamError.Create('THeapMemoryStream'); // memory allocation bug

    end;

  end;

end;



{$endif MSWINDOWS}

{$endif FPC}

{$endif LVCL}





{ TSortedWordArray }



function FastLocateWordSorted(P: PWordArray; R: integer; Value: word): PtrInt;

var L,cmp: PtrInt;

begin

  if R<0 then

    result := 0 else begin

    L := 0;

    repeat

      result := (L + R) shr 1;

      cmp := P^[result]-Value;

      if cmp=0 then begin

        result := -result-1; // return -(foundindex+1) if already exists

        exit;

      end;

      if cmp<0 then

        L := result + 1 else

        R := result - 1;

    until (L > R);

    while (result>=0) and (P^[result]>=Value) do dec(result);

    result := result+1; // return the index where to insert

  end;

end;



function TSortedWordArray.Add(aValue: Word): PtrInt;

begin

  result := FastLocateWordSorted(pointer(Values),Count-1,aValue);

  if result<0 then // aValue already exists in Values[] -> fails

    exit;

  if Count=length(Values) then

    SetLength(Values,Count+100);

  if result<Count then

    MoveFast(Values[result],Values[result+1],(Count-result)*2) else

    result := Count;

  Values[result] := aValue;

  inc(Count);

end;



function TSortedWordArray.IndexOf(aValue: Word): PtrInt;

var L,R: PtrInt;

    cmp: integer;

begin

  L := 0;

  R := Count-1;

  if 0<=R then

  repeat

    result := (L + R) shr 1;

    cmp := Values[result]-aValue;

    if cmp=0 then

      exit else

    if cmp<0 then

      L := result + 1 else

      R := result - 1;

  until (L > R);

  result := -1;

end;



{$ifdef PUREPASCAL}

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;

{$else}

function ToVarInt32(Value: PtrInt; Dest: PByte): PByte;

asm

      test eax,eax

      jnl @pos

      neg eax

      add eax,eax

      jmp ToVarUInt32

@pos: jz @zer

      lea eax,[eax*2-1]

      jmp ToVarUInt32

@zer: mov [edx],al

      lea eax,[edx+1]

end;

{$endif}



function FromVarInt32(var Source: PByte): integer;

begin // 0=0,1=1,2=-1,3=2,4=-2...

  result := integer(FromVarUInt32(Source));

  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 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 PUREPASCAL}

function ToVarUInt32(Value: PtrUInt; Dest: PByte): PByte;

begin

  if Value>$7f then

  repeat

    Dest^ := (Value and $7F) or $80;

    Value := Value shr 7;

    inc(Dest);

  until Value<=$7f;

  Dest^ := Value;

  inc(Dest);

  result := Dest;

end;

{$else}

function ToVarUInt32(Value: PtrUInt; Dest: PByte): PByte;

asm // eax=Value edx=Dest

    cmp eax,$7F

    ja @n

    mov [edx],al

    lea eax,[edx+1]

    ret

@n: mov ecx,eax

@s: and cl,$7F // handle two bytes per loop

    shr eax,7

    or cl,$80

    cmp eax,$7f

    mov [edx],cl

    lea edx,[edx+1]

    mov ecx,eax

    jbe @z

    and cl,$7F

    shr eax,7

    or cl,$80

    cmp eax,$7f

    mov [edx],cl

    mov ecx,eax

    lea edx,[edx+1]

    ja @s

@z: mov [edx],al

    lea eax,[edx+1]

end;

{$endif}



{$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;

{$else}

function FromVarUInt32(var Source: PByte): cardinal;

var c: PtrUInt;

begin

  result := Source^;

  inc(Source);

  if result<=$7f then

    exit;

  c := Source^ shl 7;

  inc(Source);

  result := result and $7F or c;

  if c<=$7f shl 7 then

    exit; // Values between 128 and 16256

  c := Source^ shl 14;

  inc(Source);

  result := result and $3FFF or c;

  if c<=$7f shl 14 then

    exit; // Values between 16257 and 2080768

  c := Source^ shl 21;

  inc(Source);

  result := result and $1FFFFF or c;

  if c<=$7f shl 21 then

    exit; // Values between 2080769 and 266338304

  c := Source^ shl 28;

  inc(Source);

  result := result and $FFFFFFF or c;

end;

{$endif}



function FromVarUInt32High(var Source: PByte): cardinal;

var c: PtrUInt;

begin

  result := Source^;

  inc(Source);

  c := Source^ shl 7;

  inc(Source);

  result := result and $7F or c;

  if c<=$7f shl 7 then

    exit; // Values between 128 and 16256

  c := Source^ shl 14;

  inc(Source);

  result := result and $3FFF or c;

  if c<=$7f shl 14 then

    exit; // Values between 16257 and 2080768

  c := Source^ shl 21;

  inc(Source);

  result := result and $1FFFFF or c;

  if c<=$7f shl 21 then

    exit; // Values between 2080769 and 266338304

  c := Source^ shl 28;

  inc(Source);

  result := result and $FFFFFFF or c;

end;



function FromVarUInt32up128(var Source: PByte): cardinal;

var c: PtrUInt;

begin

  result := Source^ shl 7;

  inc(Source);

  if result<=$7f shl 7 then

    exit; // Values between 128 and 16256

  c := Source^ shl 14;

  inc(Source);

  result := result and $3FFF or c;

  if c<=$7f shl 14 then

    exit; // Values between 16257 and 2080768

  c := Source^ shl 21;

  inc(Source);

  result := result and $1FFFFF or c;

  if c<=$7f shl 21 then

    exit; // Values between 2080769 and 266338304

  c := Source^ shl 28;

  inc(Source);

  result := result and $FFFFFFF or c;

end;



function ToVarUInt64(Value: QWord; Dest: PByte): PByte;

begin

  {$ifndef CPU64}

  if Value<MaxInt then begin

    result := ToVarUInt32(Int64Rec(Value).Lo,Dest);

    exit;

  end;

  {$endif}

  if Value>$7f then

  repeat

    Dest^ := (byte(Value) and $7F) or $80;

    Value := Value shr 7;

    inc(Dest);

  until Value<=$7f;

  Dest^ := Value;

  inc(Dest);

  result := Dest;

end;



function FromVarUInt64(var Source: PByte): QWord;

var c,n: PtrUInt;

begin

  if Source^>$7f then begin

    n := 0;

    result := PtrUInt(Source^) and $7F;

    inc(Source);

    repeat

      c := Source^;

      inc(n,7);

      if c<=$7f then

        break;

      result := result or (QWord(c and $7f) shl n);

      inc(Source);

    until false;

    result := result or (QWord(c) shl n);

  end else

    result := Source^;

  inc(Source);

end;



function ToVarInt64(Value: Int64; Dest: PByte): PByte;

begin // 0=0,1=1,2=-1,3=2,4=-2...

{$ifdef CPU64}

  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 := ToVarUInt64(Value,Dest);

{$else}

  if Value<0 then

    // -1->2, -2->4..

    result := ToVarUInt64((-Value) shl 1,Dest) else

  if Value>0 then

    // 1->1, 2->3..

    result := ToVarUInt64((Value shl 1)-1,Dest) else begin

    // 0->0

    Dest^ := 0;

    inc(Dest);

    result := Dest;

  end;

{$endif}

end;



function FromVarInt64(var 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);

    if {$ifdef CPU64}result{$else}Int64Rec(result).Lo{$endif} 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 := -(c shr 1) else

      // 1->1, 3->2..

      result := (c shr 1)+1;

  end;

  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);

    if {$ifdef CPU64}result{$else}Int64Rec(result).Lo{$endif} 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

    if c=0 then

      result := 0 else

    if c and 1<>0 then

      // 1->1, 3->2..

      result := (c shr 1)+1 else

      // 0->0, 2->-1, 4->-2..

      result := -(c shr 1);

end;



function GotoNextVarInt(Source: PByte): pointer;

begin

  if Source<>nil then begin

    while Source^>$7f do inc(Source);

    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);

  SetString(Result,PAnsiChar(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;



procedure FromVarString(var Source: PByte; var Value: RawByteString; CodePage: integer);

var Len: PtrUInt;

begin

  Len := FromVarUInt32(Source);

  if Len=0 then

    exit;

  SetString(Value,PAnsiChar(Source),Len);

  {$ifdef HASCODEPAGE}

  SetCodePage(Value,CodePage,false);

  {$endif}

  inc(Source,Len);

end;



function FromVarBlob(Data: PByte): TValueResult;

begin

  Result.Len := FromVarUInt32(Data);

  Result.Ptr := pointer(Data);

end;





{ ************ low-level RTTI types and conversion routines }





{$ifdef FPC}



function RTTIManagedSize(typeInfo: Pointer): SizeInt; inline;

begin

  case PTypeKind(typeInfo)^ of

    tkLString,tkLStringOld,tkWString,tkUString,

    tkInterface,tkDynarray:

      result := sizeof(Pointer);

    {$ifndef NOVARIANTS}

    tkVariant:

      result := sizeof(TVarData);

    {$endif}

    tkArray:

      with GetTypeInfo(typeInfo,tkArray)^ do

        result := arraySize;

        //result := (arraySize and $7FFFFFFF) * ElCount; // to be validated

    tkObject,tkRecord:

      result := GetTypeInfo(typeInfo,PTypeKind(typeInfo)^)^.recSize;

  else

    raise ESynException.CreateUTF8('RTTIManagedSize(%)',[PByte(typeInfo)^]);

  end;

end;



procedure RecordClear(var Dest; TypeInfo: pointer);

  [external name 'FPC_FINALIZE'];



procedure RecordAddRef(var Data; TypeInfo : pointer);

  [external name 'FPC_ADDREF'];



procedure RecordCopy(var Dest; const Source; TypeInfo: pointer);

begin // external name 'FPC_COPY' does not work as we need

  RecordClear(Dest,TypeInfo);

  MoveFast(Source,Dest,RTTIManagedSize(TypeInfo));

  RecordAddRef(Dest,TypeInfo);

end;



procedure CopyArray(dest, source, typeInfo: Pointer; cnt: PtrUInt);

var i, size: SizeInt;

begin

  size := RTTIManagedSize(typeInfo);

  if size>0 then

    for i := 1 to cnt do begin

      RecordClear(dest^,TypeInfo); // inlined RecordCopy()

      MoveFast(source^,dest^,size);

      RecordAddRef(dest^,TypeInfo);

      inc(PByte(source),size);

      inc(PByte(dest),size);

    end;

end;



{$else}



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;



{$endif FPC}



function RecordEquals(const RecA, RecB; TypeInfo: pointer): boolean;

var info: PTypeInfo;

    F: integer;

    Field: ^TFieldInfo;

    Diff: cardinal;

    A, B: PAnsiChar;

    {$ifndef DELPHI5OROLDER}

    DynA, DynB: TDynArray;

    {$endif}

begin

  A := @RecA;

  B := @RecB;

  if A=B then begin // both nil or same pointer

    result := true;

    exit;

  end;

  result := false;

  info := GetTypeInfo(TypeInfo,tkRecordTypeOrSet);

  if info=nil then

    exit; // raise Exception.CreateUTF8('% is not a record',[Typ^.Name]);

  Field := @info^.ManagedFields[0];

  Diff := 0;

  for F := 1 to info^.ManagedCount do begin

    Diff := Field^.Offset-Diff;

    if Diff<>0 then begin

      if not CompareMem(A,B,Diff) then

        exit; // binary block not equal

      inc(A,Diff);

      inc(B,Diff);

    end;

    case Field^.TypeInfo^.Kind of

      tkLString{$ifdef FPC},tkLStringOld{$endif}:

        if PAnsiString(A)^=PAnsiString(B)^ then

          Diff := sizeof(pointer) else

          exit;

      tkWString:

        if PWideString(A)^=PWideString(B)^ then

          Diff := sizeof(pointer) else

          exit;

      {$ifdef HASVARUSTRING}

      tkUString:

        if PUnicodeString(A)^=PUnicodeString(B)^ then

          Diff := sizeof(pointer) else

          exit;

      {$endif}

      tkRecord{$ifdef FPC},tkObject{$endif}:

        if RecordEquals(A^,B^,Field^.TypeInfo{$ifndef HASDIRECTTYPEINFO}^{$endif}) then

          Diff := RecordTypeInfoSize(Field^.TypeInfo{$ifndef HASDIRECTTYPEINFO}^{$endif}) else

          exit;

      {$ifndef NOVARIANTS}

      tkVariant:

        if PVariant(A)^=PVariant(B)^ then

          Diff := sizeof(variant) else

          exit;

      {$endif}

      {$ifndef DELPHI5OROLDER} // do not know why Delphi 5 compiler does not like it

      tkDynArray: begin

        DynA.Init(Deref(Field^.TypeInfo),A^);

        DynB.Init(Deref(Field^.TypeInfo),B^);

        if DynA.Equals(DynB) then

          Diff := sizeof(pointer) else

          exit;

      end;

      {$endif}

      tkInterface:

        if PPointer(A)^=PPointer(B)^ then

          Diff := sizeof(pointer) else

          exit;

      {$ifdef FPC} // FPC does include RTTI for unmanaged fields! :)

      else

        if Field^.TypeInfo^.Kind in tkManagedTypes then

          raise ESynException.CreateUTF8('RecordEquals(kind=%)',

            [ord(Field^.TypeInfo^.Kind)]) else begin

          if F=info^.ManagedCount then

            Diff := info.recSize-Field^.Offset else

            Diff := info^.ManagedFields[F].Offset-Field^.Offset;

          if not CompareMem(A,B,Diff) then

            exit; // binary block not equal

        end;

      {$else}

      else raise ESynException.CreateUTF8('RecordEquals(kind=%)',

        [ord(Field^.TypeInfo^.Kind)]);

      {$endif}

    end;

    inc(A,Diff);

    inc(B,Diff);

    inc(Diff,Field^.Offset);

    inc(Field);

  end;

  if CompareMem(A,B,info.recSize-Diff) then

    result := true;

end;



function RecordSaveLength(const Rec; TypeInfo: pointer): integer;

var info, infoNested: PTypeInfo;

    F, Len: integer;

    Field: ^TFieldInfo;

    P: PPtrUInt;

    R: PAnsiChar;

    DynArray: TDynArray;

begin

  R := @Rec;

  info := GetTypeInfo(TypeInfo,tkRecordTypeOrSet);

  if (R=nil) or (info=nil) then begin

    result := 0; // should have been checked before

    exit;

  end;

  Field := @info.ManagedFields[0];

  result := info.recSize;

  for F := 1 to info.ManagedCount do begin

    P := pointer(R+Field.Offset);

    case Field.TypeInfo^.Kind of

      tkDynArray: begin

        DynArray.Init(Deref(Field.TypeInfo),P^);

        inc(result,DynArray.SaveToLength-sizeof(PtrUInt));

      end;

      tkLString,tkWString{$ifdef FPC},tkLStringOld{$endif}:

        // length stored within WideString is in bytes

        if P^=0 then

          dec(result,sizeof(PtrUInt)-1) else

          inc(result,ToVarUInt32LengthWithData(PStrRec(Pointer(P^-STRRECSIZE))^.length)-sizeof(PtrUInt));

      {$ifdef HASVARUSTRING}

      tkUString:

        if P^=0 then

          dec(result,sizeof(PtrUInt)-1) else

          inc(result,ToVarUInt32LengthWithData(PStrRec(Pointer(P^-STRRECSIZE))^.length*2)-sizeof(PtrUInt));

      {$endif}

      tkRecord{$ifdef FPC},tkObject{$endif}: begin

        infoNested := Deref(Field.TypeInfo); // inlined GetTypeInfo()

        Len := RecordSaveLength(P^,infoNested);

        if Len=0 then begin

          result := 0;

          exit; // invalid/unhandled nested record content

        end;

        inc(result,Len);

        {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

        infoNested := GetFPCAlignPtr(infoNested);

        {$else}

        inc(PtrUInt(infoNested),infoNested^.NameLen);

        {$endif}

        dec(result,infoNested^.recSize);

      end;

      {$ifndef NOVARIANTS}

      tkVariant: begin

        Len := VariantSaveLength(PVariant(P)^);

        if Len=0 then begin

          result := 0;

          exit; // invalid/unhandled variant content

        end;

        inc(result,Len-sizeof(variant));

      end;

      {$endif}

      {$ifndef FPC} // FPC does include RTTI for unmanaged fields! :)

      else begin

        result := 0;

        exit; // invalid/unhandled record content

      end;

      {$endif}

    end;

    inc(Field);

  end;

end;



function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: pointer): PAnsiChar; overload;

var info, infoNested: PTypeInfo;

    F, LenBytes: integer;

    Diff: cardinal;

    Field: ^TFieldInfo;

    R: PAnsiChar;

    Kind: TTypeKind;

    DynArray: TDynArray;

begin

  R := @Rec;

  info := GetTypeInfo(TypeInfo,tkRecordTypeOrSet);

  if (R=nil) or (info=nil) then begin

    result := nil; // should have been checked before

    exit;

  end;

  Field := @info^.ManagedFields[0];

  Diff := 0;

  for F := 1 to info^.ManagedCount do begin

    Diff := Field^.Offset-Diff;

    if Diff<>0 then begin

      MoveFast(R^,Dest^,Diff);

      inc(R,Diff);

      inc(Dest,Diff);

    end;

    Kind := Field.TypeInfo^.Kind;

    case Kind of

    tkDynArray: begin

      DynArray.Init(Deref(Field.TypeInfo),R^);

      Dest := DynArray.SaveTo(Dest);

      Diff := sizeof(PtrUInt); // size of tkDynArray in record

    end;

    tkLString, tkWString {$ifdef HASVARUSTRING}, tkUString{$endif}

    {$ifdef FPC}, tkLStringOld{$endif}: begin

      if PPtrUInt(R)^=0 then

        LenBytes := 0 else

        LenBytes := PStrRec(Pointer(PPtrUInt(R)^-STRRECSIZE))^.length;

      {$ifdef HASVARUSTRING} // WideString has length in bytes, UnicodeString in WideChars

      if Kind=tkUString then

        LenBytes := LenBytes*2;

      {$endif}

      Dest := pointer(ToVarUInt32(LenBytes,pointer(Dest)));

      if LenBytes>0 then begin

        MoveFast(pointer(PPtrUInt(R)^)^,Dest^,LenBytes);

        inc(Dest,LenBytes);

      end;

      Diff := sizeof(PtrUInt); // size of tkLString+tkWString+tkUString in record

    end;

    tkRecord{$ifdef FPC},tkObject{$endif}: begin

      infoNested := Deref(Field.TypeInfo); // inlined GetTypeInfo()

      Dest := RecordSave(R^,Dest,infoNested);

      if Dest=nil then begin

        result := nil; // invalid/unhandled record content

        exit;

      end;

      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

      infoNested := GetFPCAlignPtr(infoNested);

      {$else}

      inc(PtrUInt(infoNested),infoNested^.NameLen);

      {$endif}

      Diff := infoNested^.recSize;

    end;

    {$ifndef NOVARIANTS}

    tkVariant: begin

      Dest := VariantSave(PVariant(R)^,Dest);

      if Dest=nil then begin

        result := nil; // invalid/unhandled variant content

        exit;

      end;

      Diff := sizeof(Variant); // size of tkVariant in record

    end;

    {$endif}

    {$ifdef FPC} // FPC does include RTTI for unmanaged fields! :)

      else

        if Field^.TypeInfo^.Kind in tkManagedTypes then

          raise ESynException.CreateUTF8('RecordSave(kind=%)',[ord(Field^.TypeInfo^.Kind)]) else begin

          if F=info^.ManagedCount then

            Diff := info.recSize-Field^.Offset else

            Diff := info^.ManagedFields[F].Offset-Field^.Offset;

          MoveFast(R^,Dest^,Diff);

          inc(Dest,Diff);

        end;

    {$else}

    else begin

      result := nil;

      exit; // invalid/unhandled record content

    end;

    {$endif}

    end;

    inc(R,Diff);

    inc(Diff,Field.Offset);

    inc(Field);

  end;

  Diff := info^.recSize-Diff;

  if integer(Diff)<0 then

    raise ESynException.Create('RecordSave diff') else

  if Diff<>0 then begin

    MoveFast(R^,Dest^,Diff);

    result := Dest+Diff;

  end else

    result := Dest;

end;



function RecordSave(const Rec; TypeInfo: pointer): RawByteString; overload;

var Len: integer;

begin

  Len := RecordSaveLength(Rec,TypeInfo);

  SetString(result,nil,Len);

  if Len<>0 then

    RecordSave(Rec,pointer(result),TypeInfo);

end;



function RecordSaveBase64(const Rec; TypeInfo: pointer; UriCompatible: boolean): RawUTF8;

var len: integer;

    data: RawByteString;

    dat: PAnsiChar;

begin

  result := '';

  len := RecordSaveLength(Rec,TypeInfo);

  if len=0 then

    exit;

  SetLength(data,len+4);

  dat := PAnsiChar(pointer(data))+4;

  RecordSave(Rec,dat,TypeInfo);

  PCardinal(data)^ := crc32c(0,dat,len);

  result := BinToBase64(data);

  if UriCompatible then

    Base64ToURI(result);

end;



function RecordLoadBase64(Source: PAnsiChar; Len: integer; var Rec;

  TypeInfo: pointer; UriCompatible: boolean): boolean;

var data: RawByteString;

    uri: RawUTF8;

begin

  result := false;

  if Len<=6 then

    exit;

  if UriCompatible then begin

    SetString(uri,Source,Len);

    Base64FromURI(uri);

    data := Base64ToBin(uri);

  end else

    data := Base64ToBin(Source,Len);

  Len := length(data);

  if Len<=4 then

    exit;

  Source := PAnsiChar(pointer(data))+4;

  if crc32c(0,Source,Len-4)=PCardinal(data)^ then

    result := RecordLoad(Rec,Source,TypeInfo)<>nil;

end;



procedure _Finalize(Data: Pointer; TypeInfo: Pointer);

{$ifdef FPC}

  [external name 'FPC_FINALIZE'];

{$else}

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}

{$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

        {$ifdef DELPHI5OROLDER}

        jmp System.@RunError

        {$else}

        jmp System.Error

        {$endif}

@@array:movzx ecx,[edx].TTypeInfo.NameLen

        add ecx,edx

        mov edx,dword ptr [ecx].TTypeInfo.ManagedFields[0] // Fields[0].TypeInfo^

        mov ecx,[ecx].TTypeInfo.ManagedCount

        mov edx,[edx]

        jmp System.@FinalizeArray

{$endif CPU64}

end;

{$endif FPC}



function RecordLoad(var Rec; Source: PAnsiChar; TypeInfo: pointer): PAnsiChar;

var info, infoNested: PTypeInfo;

    F, LenBytes: integer;

    Diff: cardinal;

    Field: ^TFieldInfo;

    R: PAnsiChar;

    Kind: TTypeKind;

    DynArray: TDynArray;

begin

  R := @Rec;

  info := GetTypeInfo(TypeInfo,tkRecordTypeOrSet);

  if (R=nil) or (info=nil) then begin

    result := nil; // should have been checked before

    exit;

  end;

  Field := @info^.ManagedFields[0];

  if Source=nil then begin  // inline RecordClear() function

    for F := 1 to  info^.ManagedCount do begin

      _Finalize(R+Field^.Offset,Deref(Field^.TypeInfo));

      inc(Field);

    end;

    result := nil;

    exit;

  end;

  Diff := 0;

  for F := 1 to info^.ManagedCount do begin

    Diff := Field^.Offset-Diff;

    if Diff<>0 then begin

      MoveFast(Source^,R^,Diff);

      inc(Source,Diff);

      inc(R,Diff);

    end;

    Kind := Field.TypeInfo^.Kind;

    case Kind of

    tkDynArray: begin

      DynArray.Init(Deref(Field.TypeInfo),R^);

      Source := DynArray.LoadFrom(Source);

      Diff := sizeof(PtrUInt); // size of tkDynArray in record

    end;

    tkLString, tkWString {$ifdef HASVARUSTRING}, tkUString{$endif}

    {$ifdef FPC}, tkLStringOld{$endif}: begin

      LenBytes := FromVarUInt32(PByte(Source));

      case Kind of

        tkLString{$ifdef FPC},tkLStringOld{$endif}: begin

          SetString(PRawByteString(R)^,Source,LenBytes);

          {$ifdef HASCODEPAGE}

          { Delphi 2009+: set Code page for this AnsiString }

          if LenBytes<>0 then begin

            infoNested := Deref(Field.TypeInfo); 

            SetCodePage(PRawByteString(R)^,

              PWord(PtrUInt(infoNested)+infoNested^.NameLen+2)^,false);

          end;

          {$endif}

        end;

        tkWString:

          SetString(PWideString(R)^,PWideChar(Source),LenBytes shr 1);

        {$ifdef HASVARUSTRING}

        tkUString:

          SetString(PString(R)^,PWideChar(Source),LenBytes shr 1);

        {$endif}

      end;

      inc(Source,LenBytes);

      Diff := sizeof(PtrUInt); // size of tkLString+tkWString+tkUString in record

    end;

    tkRecord{$ifdef FPC},tkObject{$endif}: begin

      infoNested := Deref(Field.TypeInfo); // inlined GetTypeInfo()

      Source := RecordLoad(R^,Source,infoNested);

      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

      infoNested := GetFPCAlignPtr(infoNested);

      {$else}

      inc(PtrUInt(infoNested),infoNested^.NameLen);

      {$endif}

      Diff := infoNested^.recSize;

    end;

    {$ifndef NOVARIANTS}

    tkVariant: begin

      Source := VariantLoad(PVariant(R)^,Source,@JSON_OPTIONS[true]);

      Diff := sizeof(Variant); // size of tkVariant in record

    end;

    {$endif}

    {$ifdef FPC} // FPC does include RTTI for unmanaged fields! :)

      else

        if Field^.TypeInfo^.Kind in tkManagedTypes then

          raise ESynException.CreateUTF8('RecordLoad(kind=%)',[ord(Field^.TypeInfo^.Kind)]) else begin

          if F=info^.ManagedCount then

            Diff := info.recSize-Field^.Offset else

            Diff := info^.ManagedFields[F].Offset-Field^.Offset;

          MoveFast(Source^,R^,Diff);

          inc(Source,Diff);

        end;

    {$else}

    else begin

      result := nil;

      exit; // invalid/unhandled record content

    end;

    {$endif}

    end;

    inc(R,Diff);

    inc(Diff,Field.Offset);

    inc(Field);

  end;

  Diff := info^.recSize-Diff;

  if integer(Diff)<0 then

    raise ESynException.Create('RecordLoad diff') else

  if Diff<>0 then begin

    MoveFast(Source^,R^,Diff);

    result := Source+Diff;

  end else

    result := 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;



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]

        lea esi,[esi+8]

        movzx ecx,[edx].TTypeInfo.Kind

        lea eax,[eax+ebx] // eax=data to be initialized

        jmp dword ptr [@@Tab+ecx*4-tkLString*4]

@@Tab:  dd @@ptr, @@ptr, @@variant, @@array, @@array, @@ptr, @@ptr, @@ptr, @@ptr

@@ptr:  dec edi

        mov dword ptr [eax],0 // pointer initialization

        jg @@loop

@@end:  pop edi

        pop esi

        pop ebx

        ret

@@variant:

        xor ecx,ecx

        dec edi

        mov dword ptr [eax],ecx

        mov dword ptr [eax+4],ecx

        mov dword ptr [eax+8],ecx

        mov dword ptr [eax+12],ecx

        jg @@loop

        pop edi

        pop esi

        pop ebx

        ret

@@array:mov ecx,1 // here eax=data edx=typeinfo

        call System.@InitializeArray

        dec edi

        jg @@loop

        pop edi

        pop esi

        pop ebx

end;



{$ifndef UNICODE} // TMonitor.Destroy is not available ! -> apply to D2007 only

procedure TObjectCleanupInstance;

asm // faster version by AB

        push ebx

        mov ebx,eax

@@loop: mov ebx,[ebx] // handle three VMT levels per iteration

        mov edx,[ebx].vmtInitTable

        mov ebx,[ebx].vmtParent

        test edx,edx

        jnz @@clr

        test ebx,ebx

        jz @@end

        mov ebx,[ebx]

        mov edx,[ebx].vmtInitTable

        mov ebx,[ebx].vmtParent

        test edx,edx

        jnz @@clr

        test ebx,ebx

        jz @@end

        mov ebx,[ebx]

        mov edx,[ebx].vmtInitTable

        mov ebx,[ebx].vmtParent

        test edx,edx

        jnz @@clr

        test ebx,ebx

        jnz @@loop

@@end:  pop ebx

        ret

@@clr:  push offset @@loop // TObject has no vmtInitTable -> safe

        jmp RecordClear // eax=self edx=typeinfo

end;

{$endif}



procedure RecordClear(var Dest; TypeInfo: pointer);

asm // faster version by AB (direct call to finalization procedures)

        { ->    EAX pointer to record to be finalized   }

        {       EDX pointer to type info                }

        { <-    EAX pointer to record to be finalized   }

        movzx ecx,byte ptr [edx].TTypeInfo.NameLen

        push ebx

        mov ebx,eax

        push esi         

        push edi

        mov edi,[edx+ecx].TTypeInfo.ManagedCount

        lea esi,[edx+ecx].TTypeInfo.ManagedFields

        test edi,edi

        jz @@end

@@loop: mov edx,[esi].TFieldInfo.TypeInfo

        mov eax,[esi].TFieldInfo.&Offset

        mov edx,[edx]

        lea esi,[esi+8]

        movzx ecx,[edx].TTypeInfo.Kind

        lea eax,[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

        lea esi,[esi+ecx]

        lea edi,[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 @@DynArray

{$endif}ja @@err

        jmp dword ptr [ecx*4+@@tab-tkWString*4]

@@Tab:  dd @@WString,@@Variant,@@Array,@@Record,@@Interface,@@err

        {$ifdef UNICODE}dd @@DynArray{$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} cmp dword ptr [VarCopyProc],0

        mov edx,esi

        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

@@DynArray:

        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

        dec ebp    // any other TFieldInfo?

        lea ebx,[ebx+8]

        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 DOPATCHTRTL}

{$endif FPC}



{$ifndef FPC}

{$ifndef CPUARM}



function SystemFillCharAddress: Pointer;

asm

  {$ifdef CPU64}

  mov rax,offset System.@FillChar

  {$else}

  mov eax,offset System.@FillChar

  {$endif}

end;



{$ifdef CPU64}



{ Some notes about MOVNTI opcode use below:

  - Delphi inline assembler is not able to compile the instruction -> so we

    had to write some manual DB $... values instead :(

  - The I in MOVNTI means "non-temporal hint". It is implemented by using a

    write combining (WC) memory type protocol when writing the data to memory.

    The processor does not write the data into the cache hierarchy, nor does

    it fetch the corresponding cache line from memory into the cache hierarchy.

    By-passing the cache should enhance move() speed of big memory blocks. }



procedure MoveSSE2; // Johan Bontes refactored revision

asm // rcx=Source, rdx=Dest, r8=Count

               .noframe

               .align 16

               sub rcx,rdx

               push rbx                 //allow better alignment of loops (saves a cycle).

               mov rax,r8

               mov r11d,128             //code shink in prefetch loop

               je @done

               jnc @MoveForwards

               add rax,rcx

               jc @MoveBackwards

@MoveForwards: cmp r8,8

               jl @Below8

               test dl,07H

               jz @IsAbove32

               test dl,01H

               jz @TryMoveWord

               mov al,[rcx+rdx]

               dec r8

               mov [rdx],al

               dec rdx

@TryMoveWord:  test dl,02H

               jz @TryMoveDWord

               mov ax,[rcx+rdx]

               sub r8,2

               mov [rdx],ax

               add rdx,2

@TryMoveDWord: test dl,04H

               jz @IsAbove32

               mov eax,[rcx+rdx]

               sub r8,4

               mov [rdx],eax

               add rdx,4

@IsAbove32:    mov rbx,r8

               shr rbx,5

               jnz @Above32

@IsBelow8:     mov rax,r8

               shr eax,3

               jz @Below8

@Loop8:        dec eax

               mov rbx,[rcx+rdx]

               mov [rdx],rbx

               lea rdx,[rdx+8]

               jnz @Loop8

               and r8d,7

@Below8:       test r8,r8

               jle @done

@MovePerByte:  dec r8

               mov al,[rcx+rdx]

               mov [rdx],al

               lea rdx,[rdx+1]

               jnz @MovePerByte

@done:         pop rbx

               ret

               nop

@Above32:      cmp rbx,8192

               jc @Below8192

               mov eax,32

               cmp rcx,4096

               jnc @Prefetch_4K

@Below8192:

@loop8192:     dec ebx

               mov rax,[rcx+rdx]

               mov r11,[rcx+rdx+08H]

               mov [rdx],rax

               mov [rdx+08H],r11

               mov rax,[rcx+rdx+10H]

               mov r11,[rcx+rdx+18H]

               mov [rdx+10H],rax

               mov [rdx+18H],r11

               lea rdx,rdx+32

               jnz @Loop8192

               and r8d,1FH

               jmp @IsBelow8

@Prefetch_4K:  //assert eax=32

@PrefetchLoop: prefetchnta [rcx+rdx]

               prefetchnta [rcx+rdx+40H]

               add rdx,r11

               dec eax

               jnz @PrefetchLoop

               sub rdx,4096

               mov eax,64

               db $0F,$1F,$40,$00                           //nop4

@Loop64:       mov rbx,[rcx+rdx]

               mov r10,[rcx+rdx+08H]

               db $48,$0F,$C3,$1A     // movnti [rdx],rbx

               db $4C,$0F,$C3,$52,$08 // movnti [rdx+08H],r10

               mov rbx,[rcx+rdx+10H]

               mov r10,[rcx+rdx+18H]

               dec eax

               db $48,$0F,$C3,$5A,$10 // movnti [rdx+10H],rbx

               db $4C,$0F,$C3,$52,$18 // movnti [rdx+18],r10

               mov rbx,[rcx+rdx+20H]

               mov r10,[rcx+rdx+28H]

               db $48,$0F,$C3,$5A,$20 // movnti [rdx+20H],rbx

               db $4C,$0F,$C3,$52,$28 // movnti [rdx+28H],r10

               mov rbx,[rcx+rdx+30H]

               mov r10,[rcx+rdx+38H]

               db $48,$0F,$C3,$5A,$30 // movnti [rdx+30H],rbx

               db $4C,$0F,$C3,$52,$38 // movnti [rdx+38H],r10

               lea rdx,rdx+64

               jnz @Loop64

               cmp r8,(4096*2)

               lea r8,r8-4096

               mov eax,32

               jnc @Prefetch_4K

               mfence

               jmp @IsAbove32



@MoveBackwards:add rdx,r8

               cmp r8,8

               jl @IsEmpty

               test dl,07H

               jz @IsAbove32_2

               test dl,01H

               jz @TryMoveWord2

               dec rdx

               mov al,[rcx+rdx]

               dec r8

               mov [rdx],al

@TryMoveWord2: test dl,02H

               jz @TryMoveDWord2

               sub rdx,2

               mov ax,[rcx+rdx]

               sub r8,2

               mov [rdx],ax

@TryMoveDWord2:test dl,04H

               jz @IsAbove32_2

               sub rdx,4

               mov eax,[rcx+rdx]

               sub r8,4

               rep mov [rdx],eax

@IsAbove32_2:  rep mov rbx,r8

               shr rbx,5

               jnz @Below8K

@IsBelow8_2:   rep mov rbx,r8

               shr rbx,3

               jz @IsEmpty

@Loop8_2:      sub rdx,8

               mov rax,[rcx+rdx]

               dec rbx

               mov [rdx],rax

               jnz @Loop8_2

               and r8d,07H

@IsEmpty:      test r8,r8

               jle @Return

@MovePerByte2: dec rdx

               mov al,[rcx+rdx]

               dec r8

               mov  [rdx],al

               jnz @MovePerByte2

@Return:       pop rbx

               ret

@Below8K:      cmp rbx,8192

               jc @Loop32

               cmp rcx,-4096

               jc @Prefetch_4K2

@Loop32:       sub rdx,32

               dec ebx

               mov rax,[rcx+rdx+18H]

               mov r10,[rcx+rdx+10H]

               mov [rdx+18H],rax

               mov [rdx+10H],r10

               mov rax,[rcx+rdx+8H]

               mov r10,[rcx+rdx]

               mov [rdx+8H],rax

               mov [rdx],r10

               jnz @Loop32

               and r8d,1FH

               jmp @IsBelow8_2

@Prefetch_4K2: rep mov eax,32

@PrefetchLoop2:sub rdx,r11

               prefetchnta [rcx+rdx]

               prefetchnta [rcx+rdx+40H]

               dec eax

               jnz @PrefetchLoop2

               add rdx,4096

               mov eax,64              //eax is always zero at this point.

               db $66,$0F,$1F,$00

@Loop64_2:     sub rdx,64

               dec eax

               mov rbx,[rcx+rdx+38H]

               mov r10,[rcx+rdx+30H]

               db $48,$0F,$C3,$5A,$38 // movnti [rdx+38H],rbx

               db $4C,$0F,$C3,$52,$30 // movnti [rdx+30H],r10

               mov rbx,[rcx+rdx+28H]

               mov r10,[rcx+rdx+20H]

               db $48,$0F,$C3,$5A,$28 // movnti [rdx+28H],rbx

               db $4C,$0F,$C3,$52,$20 // movnti [rdx+20H],r10



               mov rbx,[rcx+rdx+18H]

               mov r10,[rcx+rdx+10H]

               db $48,$0F,$C3,$5A,$18 // movnti [rdx+18H],rbx

               db $4C,$0F,$C3,$52,$10 // movnti [rdx+10H],r10

               mov rbx,[rcx+rdx+8H]

               mov r10,[rcx+rdx]

               db $48,$0F,$C3,$5A,$08 // movnti [rdx+8H],rbx

               db $4C,$0F,$C3,$12     // movnti [rdx],r10

               jnz @Loop64_2

               cmp r8,(4096*2)

               lea r8,r8-4096

               jnc @Prefetch_4K2

               mfence

               jmp @IsAbove32_2

end;



procedure FillCharSSE2; // Johan Bontes refactored revision

asm

              .noframe

              .align 16

              movzx r8,r8b           //There's no need to optimize for count <= 3

              mov rax,$0101010101010101

              mov r11d,edx

              imul rax,r8            //fill rax with value.

              cmp rdx,63             //fix: allow fills > 4GB

              jg  @Above32

@Below32:     and  r11d,not(3)

              lea   r10,[rip + @SmallFill + (15*4)]

              jz @SizeIs3

              sub   r10,r11

              jmp   r10

              db $66,$90

@SmallFill:   rep mov [rcx+56], eax

              rep mov [rcx+52], eax

              rep mov [rcx+48], eax

              rep mov [rcx+44], eax

              rep mov [rcx+40], eax

              rep mov [rcx+36], eax

              rep mov [rcx+32], eax

              rep mov [rcx+28], eax

              rep mov [rcx+24], eax

              rep mov [rcx+20], eax

              rep mov [rcx+16], eax

              rep mov [rcx+12], eax

              rep mov [rcx+08], eax

              rep mov [rcx+04], eax

              mov [rcx],eax

@Fallthough:  mov [rcx+rdx-4],eax  //unaligned write to fix up tail

              rep ret

@SizeIs3:     lea edx,[edx*2+edx]           //r9 <= 3  r9*4

              add r10,$1B                   //reuse rip (saves 4 bytes)

              sub r10,rdx

              jmp r10

@do3:         mov [rcx+2],al

@do2:         mov [rcx+1],al

@do1:         mov [rcx],al

              ret

@do0:         rep ret

@Above32:     mov r11,rcx

              mov r8b,7              //code shrink to help alignment.

              lea r9,[rcx+rdx]       //r9=end of array

              sub rdx,8

              mov [rcx],rax

              add rcx,8

              and r11,r8             //and 7 See if dest is aligned

              add rdx,r11

              mov [r9-8],rax         //do a tail write to align.

@tail:        and r9,r8              //and 7 is tail aligned?

@tailwrite:   sub rdx,r9             //dec(count, tailcount)

@alignOK:     mov r10,rdx

              xor rcx,r11            //align dest

              shr r10,6

              and edx,(32+16+8)      //count the partial iterations of the loop

              mov r8b,64             //code shrink to help alignment.

              mov r9,rdx

              jz @Initloop64

@partialloop: lea r11,[rip + @partial +(4*7)] //start at the end of the loop

              shr r9,1               //every instruction is 4 bytes

              sub r11,r9             //step back as needed

              add rcx,rdx            //add the partial loop count to dest

              test r10,r10           //do we need to do more loops after partial?

              stc                    //CF=1: we're in a partial loop

              jmp r11                //do a partial loop



@Initloop64:  mov rdx,r10

              shr r10,(19-6)         //use non-temporal move for > 512kb

              jnz @InitFillHuge

@Doloop64:    add rcx,r8

              dec edx

              mov [rcx-64+00H],rax

@partial:     mov [rcx-64+08H],rax

              mov [rcx-64+10H],rax

              mov [rcx-64+18H],rax

              mov [rcx-64+20H],rax

              mov [rcx-64+28H],rax

              mov [rcx-64+30H],rax

              mov [rcx-64+38H],rax

              jnbe @DoLoop64         //repeat while not(partial) and not(done)

              jnz @InitLoop64        //(re)start the loop if not done

@done:        rep ret                //rep ret saves 25! cycles.

              db $66,$90             //nop

@InitFillHuge:

@FillHuge:    add rcx,r8             // movdqnt is the same speed, but more hassle

              dec rdx

              db $48,$0F,$C3,$41,$C0 // movnti  [rcx-64+00H],rax

              db $48,$0F,$C3,$41,$C8 // movnti  [rcx-64+08H],rax

              db $48,$0F,$C3,$41,$D0 // movnti  [rcx-64+10H],rax

              db $48,$0F,$C3,$41,$D8 // movnti  [rcx-64+18H],rax

              db $48,$0F,$C3,$41,$E0 // movnti  [rcx-64+20H],rax

              db $48,$0F,$C3,$41,$E8 // movnti  [rcx-64+28H],rax

              db $48,$0F,$C3,$41,$F0 // movnti  [rcx-64+30H],rax

              db $48,$0F,$C3,$41,$F8 // movnti  [rcx-64+38H],rax

              jnz @FillHuge

@donefillhuge:mfence

end;



function StrLenSSE2(S: pointer): PtrInt;

asm // from GPL strlen64.asm by Agner Fog - www.agner.org/optimize

        .NOFRAME

        test     rcx,rcx

        mov      rax,rcx             // get pointer to string from rcx

        mov      r8,rcx              // copy pointer

        jz       @null               // returns 0 if S=nil

        // rax = s,ecx = 32 bits of s

        pxor     xmm0,xmm0           // set to zero

        and      ecx,0FH             // lower 4 bits indicate misalignment

        and      rax,-10H            // align pointer by 16

        movdqa   xmm1,[rax]          // read from nearest preceding boundary

        pcmpeqb  xmm1,xmm0           // compare 16 bytes with zero

        pmovmskb edx,xmm1            // get one bit for each byte result

        shr      edx,cl              // shift out false bits

        shl      edx,cl              // shift back again

        bsf      edx,edx             // find first 1-bit

        jnz      @L2                 // found

        // Main loop, search 16 bytes at a time

@L1:    add      rax,10H             // increment pointer by 16

        movdqa   xmm1,[rax]          // read 16 bytes aligned

        pcmpeqb  xmm1,xmm0           // compare 16 bytes with zero

        pmovmskb edx,xmm1            // get one bit for each byte result

        bsf      edx,edx             // find first 1-bit

        // (moving the bsf out of the loop and using test here would be faster

        // for long strings on old processors, but we are assuming that most

        // strings are short, and newer processors have higher priority)

        jz       @L1                 // loop if not found

@L2:    // Zero-byte found. Compute string length

        sub      rax,r8              // subtract start address

        add      rax,rdx             // add byte index

@null:

end;



const

  EQUAL_EACH = 8;   // see https://msdn.microsoft.com/en-us/library/bb531463

  NEGATIVE_POLARITY = 16;



{$ifdef HASAESNI}

function StrLenSSE42(S: pointer): PtrInt;

asm // rcx=S

        .NOFRAME

        test      rcx,rcx

        mov       rdx,rcx

        mov       rax,-16

        jz        @null

        pxor      xmm0,xmm0

@L:     add       rax,16   // add before comparison flag

        pcmpistri xmm0,[rdx+rax],EQUAL_EACH

        jnz       @L

        add       rax,rcx

        ret

@null:  xor       rax,rax

end;

{$endif}



{$else CPU64}



{$ifndef PUREPASCAL}



procedure FillCharX87;

asm // eax=Dest edx=Count cl=Value

        // faster version by John O'Harrow  (Code Size = 153 Bytes)

        cmp   edx,32

        mov   ch,cl                 // copy value into both bytes of cx

        jl    @small

        mov   [eax  ],cx            // fill first 8 bytes

        mov   [eax+2],cx

        mov   [eax+4],cx

        mov   [eax+6],cx

        sub   edx,16

        fld   qword ptr [eax]

        fst   qword ptr [eax+edx]    // fill last 16 bytes

        fst   qword ptr [eax+edx+8]

        mov   ecx,eax

        and   ecx,7                 // 8-byte align writes

        sub   ecx,8

        sub   eax,ecx

        add   edx,ecx

        add   eax,edx

        neg   edx

@loop:  fst   qword ptr [eax+edx]    // fill 16 bytes per loop

        fst   qword ptr [eax+edx+8]

        add   edx,16

        jl    @loop

        ffree st(0)

        fincstp

        ret

        nop

@small: test  edx,edx

        jle   @done

        mov   [eax+edx-1],cl        // fill last byte

        and   edx,-2                // no. of words to fill

        neg   edx

        lea   edx,[@fill+60+edx*2]

        jmp   edx

        nop                          // align jump destinations

        nop

@fill:  mov   [eax+28],cx

        mov   [eax+26],cx

        mov   [eax+24],cx

        mov   [eax+22],cx

        mov   [eax+20],cx

        mov   [eax+18],cx

        mov   [eax+16],cx

        mov   [eax+14],cx

        mov   [eax+12],cx

        mov   [eax+10],cx

        mov   [eax+ 8],cx

        mov   [eax+ 6],cx

        mov   [eax+ 4],cx

        mov   [eax+ 2],cx

        mov   [eax   ],cx

        ret                         // for alignment

@done:  db $f3 // rep ret AMD trick here

end;



/// faster implementation of Move() for Delphi versions with no FastCode inside

procedure MoveX87;

asm // eax=source edx=dest ecx=count

         // original code by John O'Harrow - included since delphi 2007

        cmp     eax,edx

        jz      @exit                 // exit if source=dest

        cmp     ecx,32

        ja      @lrg                  // count > 32 or count < 0

        sub     ecx,8

        jg      @sml                  // 9..32 byte move

        jmp     dword ptr [@table+32+ecx*4]   // 0..8 byte move

@sml:   fild    qword ptr [eax+ecx]   // load last 8

        fild    qword ptr [eax]       // load first 8

        cmp     ecx,8

        jle     @sml16

        fild    qword ptr [eax+8]     // load second 8

        cmp     ecx,16

        jle     @sml24

        fild    qword ptr [eax+16]    // load third 8

        fistp   qword ptr [edx+16]    // save third 8

@sml24: fistp   qword ptr [edx+8]     // save second 8

@sml16: fistp   qword ptr [edx]       // save first 8

        fistp   qword ptr [edx+ecx]   // save last 8

        ret

@exit:  rep ret

@table: dd @exit,@m01,@m02,@m03,@m04,@m05,@m06,@m07,@m08

@lrgfwd:push    edx

        fild    qword ptr [eax]       // first 8

        lea     eax,[eax+ecx-8]

        lea     ecx,[ecx+edx-8]

        fild    qword ptr [eax]       // last 8

        push    ecx

        neg     ecx

        and     edx,-8                // 8-byte align writes

        lea     ecx,[ecx+edx+8]

        pop     edx

@fwd:   fild    qword ptr [eax+ecx]

        fistp   qword ptr [edx+ecx]

        add     ecx,8

        jl      @fwd

        fistp   qword ptr [edx]       // last 8

        pop     edx

        fistp   qword ptr [edx]       // first 8

        ret

@lrg:   jng     @exit                 // count < 0

        cmp     eax,edx

        ja      @lrgfwd

        sub     edx,ecx

        cmp     eax,edx

        lea     edx,[edx+ecx]

        jna     @lrgfwd

        sub     ecx,8                 // backward move

        push    ecx

        fild    qword ptr [eax+ecx]   // last 8

        fild    qword ptr [eax]       // first 8

        add     ecx,edx

        and     ecx,-8                // 8-byte align writes

        sub     ecx,edx

@bwd:   fild    qword ptr [eax+ecx]

        fistp   qword ptr [edx+ecx]

        sub     ecx,8

        jg      @bwd

        pop     ecx

        fistp   qword ptr [edx]       // first 8

        fistp   qword ptr [edx+ecx]   // last 8

        ret

@m01:   movzx   ecx,byte ptr [eax]

        mov     [edx],cl

        ret

@m02:   movzx   ecx,word ptr [eax]

        mov     [edx],cx

        ret

@m03:   mov     cx,[eax]

        mov     al,[eax+2]

        mov     [edx],cx

        mov     [edx+2],al

        ret

@m04:   mov     ecx,[eax]

        mov     [edx],ecx

        ret

@m05:   mov     ecx,[eax]

        mov     al,[eax+4]

        mov     [edx],ecx

        mov     [edx+4],al

        ret

@m06:   mov     ecx,[eax]

        mov     ax,[eax+4]

        mov     [edx],ecx

        mov     [edx+4],ax

        ret

@m07:   mov     ecx,[eax]

        mov     eax,[eax+3]

        mov     [edx],ecx

        mov     [edx+3],eax

        ret

@m08:   mov     ecx,[eax]

        mov     eax,[eax+4]

        mov     [edx],ecx

        mov     [edx+4],eax

end;



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 }

@@SetResult:

     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

  cmp       edx, 32

  mov       ch,cl                {copy value into both bytes of cx}

  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;



function StrLenSSE2(S: pointer): PtrInt;

asm // from GPL strlen32.asm by Agner Fog - www.agner.org/optimize

        test     eax,eax

        mov      ecx,eax             // copy pointer

        jz       @null               // returns 0 if S=nil

        push     eax                 // save start address

        pxor     xmm0,xmm0           // set to zero

        and      ecx,0FH             // lower 4 bits indicate misalignment

        and      eax,-10H            // align pointer by 16

        movdqa   xmm1,[eax]          // read from nearest preceding boundary

        pcmpeqb  xmm1,xmm0           // compare 16 bytes with zero

        pmovmskb edx,xmm1            // get one bit for each byte result

        shr      edx,cl              // shift out false bits

        shl      edx,cl              // shift back again

        bsf      edx,edx             // find first 1-bit

        jnz      @A200               // found

        // Main loop, search 16 bytes at a time

@A100:  add      eax,10H             // increment pointer by 16

        movdqa   xmm1,[eax]          // read 16 bytes aligned

        pcmpeqb  xmm1,xmm0           // compare 16 bytes with zero

        pmovmskb edx,xmm1            // get one bit for each byte result

        bsf      edx,edx             // find first 1-bit

        // (moving the bsf out of the loop and using test here would be faster

        // for long strings on old processors, but we are assuming that most

        // strings are short, and newer processors have higher priority)

        jz       @A100               // loop if not found

@A200:  // Zero-byte found. Compute string length

        pop      ecx                 // restore start address

        sub      eax,ecx             // subtract start address

        add      eax,edx             // add byte index

@null:

end;



function StrLenSSE42(S: pointer): PtrInt;

asm // warning: may read up to 15 bytes beyond the string itself

        test      eax,eax

        mov       edx,eax             // copy pointer

        jz        @null               // returns 0 if S=nil

        xor       eax,eax

        pxor      xmm0,xmm0

        {$ifdef HASAESNI}

        pcmpistri xmm0,dqword [edx],EQUAL_EACH  // comparison result in ecx

        {$else}

        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;



{$endif DELPHI5OROLDER}



{$endif PUREPASCAL}



{$endif CPU64}



procedure InitRedirectCode;

begin

  {$ifdef DELPHI5OROLDER}

  StrLen := @StrLenX86;

  FillcharFast := @FillCharX87;

  MoveFast := @MoveX87;

  {$else}

  {$ifdef CPU64}

  {$ifdef HASAESNI}

  if cfSSE42 in CpuFeatures then

    StrLen := @StrLenSSE42 else

  {$endif}

    StrLen := @StrLenSSE2;

  FillcharFast := @FillCharSSE2;

  //MoveFast := @MoveSSE2; // actually slower than RTL's for small blocks

  {$else}

  {$ifdef PUREPASCAL}

  Pointer(@FillCharFast) := SystemFillCharAddress;

  {$else}

  if cfSSE2 in CpuFeatures then begin

    if cfSSE42 in CpuFeatures then

      StrLen := @StrLenSSE42 else

      StrLen := @StrLenSSE2;

    FillcharFast := @FillCharSSE2;

  end else begin

    StrLen := @StrLenX86;

    FillcharFast := @FillCharX87;

  end;

  MoveFast := @MoveX87; // SSE2 is not faster than X87 version on 32 bit CPU

  {$endif PUREPASCAL}

  {$endif CPU64}

  {$endif DELPHI5OROLDER}

  // do redirection from RTL to our fastest version

  {$ifdef DOPATCHTRTL}

  if DebugHook=0 then begin // patch only outside debugging

    RedirectCode(SystemFillCharAddress,@FillcharFast);

    RedirectCode(@System.Move,@MoveFast);

    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}

  end;

  {$endif DOPATCHTRTL}

end;



{$endif CPUARM}



{$endif FPC}





{ ************  Custom record / dynamic array JSON serialization }



procedure SaveJSON(const Value; TypeInfo: pointer;

  EnumSetsAsText: boolean; var result: RawUTF8);

begin

  with DefaultTextWriterJSONClass.CreateOwnedStream do

  try

    if EnumSetsAsText then

      CustomOptions := CustomOptions+[twoEnumSetsAsTextInRecord];

    AddTypedJSON(TypeInfo,Value,EnumSetsAsText,true);

    SetText(result);

  finally

    Free;

  end;

end;



function SaveJSON(const Value; TypeInfo: pointer;

  EnumSetsAsText: boolean=false): RawUTF8;

begin

  SaveJSON(Value,TypeInfo,EnumSetsAsText,result);

end;



type

  /// information about one customized JSON serialization

  TJSONCustomParserRegistration = record

    RecordTypeName: 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;

    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 DynArraySearch(aDynArrayTypeInfo, aRecordTypeInfo: pointer;

      out Reader: TDynArrayJSONCustomReader): boolean; overload;

    function DynArraySearch(aDynArrayTypeInfo, aRecordTypeInfo: pointer;

      out Writer: TDynArrayJSONCustomWriter; PParser: PTJSONCustomParserAbstract): boolean; 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;

  public

    constructor Create;

    procedure RegisterCallbacks(aTypeInfo: pointer;

      aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter);

    function RegisterFromText(aTypeInfo: pointer;

      const aRTTIDefinition: RawUTF8): TJSONRecordAbstract;

    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;

    info: PTypeInfo;

    added: boolean;

    ndx: integer;

begin

  result := -1;

  info := GetTypeInfo(aRecordTypeInfo,tkRecordTypeOrSet);

  if info=nil then

    exit; // not enough RTTI

  Reg.RecordTypeInfo := aRecordTypeInfo;

  Reg.DynArrayTypeInfo := aDynArrayTypeInfo;

  TypeInfoToName(Reg.RecordTypeInfo,Reg.RecordTypeName);

  if Reg.RecordTypeName='' then

    exit; // we need a type name!

  RegRoot := TJSONCustomParserRTTI.CreateFromTypeName('',Reg.RecordTypeName);

  {$ifdef ISDELPHI2010}

  if RegRoot=nil then begin

    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;

begin

  if self<>nil then

  if (aDynArrayTypeInfo<>nil) and (fParsersCount<>0) then

    if fParser[fLastDynArrayIndex].DynArrayTypeInfo=aDynArrayTypeInfo then begin

      result := fLastDynArrayIndex;

      exit;

    end else begin

      if aRecordTypeInfo=nil then // record RTTI not specified: guess now

        aRecordTypeInfo := DynArrayTypeInfoToRecordInfo(aDynArrayTypeInfo);

      if aRecordTypeInfo=nil then begin

        for result := 0 to fParsersCount-1 do

          if fParser[result].DynArrayTypeInfo=aDynArrayTypeInfo then begin

            fLastDynArrayIndex := result;

            exit;

          end;

      end else

      if (cardinal(fLastRecordIndex)<cardinal(fParsersCount)) and

         (fParser[fLastRecordIndex].RecordTypeInfo=aRecordTypeInfo) then begin

        result := fLastRecordIndex;

        exit;

      end else

      for result := 0 to fParsersCount-1 do

        with fParser[result] do

        if (DynArrayTypeInfo=aDynArrayTypeInfo) or

           (RecordTypeInfo=aRecordTypeInfo) then begin

          fLastDynArrayIndex := result;

          fLastRecordIndex := result;

          exit;

        end;

    end;

  if AddIfNotExisting then begin

    result := TryToGetFromRTTI(aDynArrayTypeInfo,aRecordTypeInfo);

    if result>=0 then

      GlobalJSONCustomParsers.fLastRecordIndex := result;

  end else

    result := -1;

end;



function TJSONCustomParsers.DynArraySearch(aDynArrayTypeInfo,aRecordTypeInfo: pointer;

  out Reader: TDynArrayJSONCustomReader): boolean;

var ndx: integer;

begin

  ndx := DynArraySearch(aDynArrayTypeInfo,aRecordTypeInfo);

  if (ndx>=0) and Assigned(GlobalJSONCustomParsers.fParser[ndx].Reader) then begin

    Reader := GlobalJSONCustomParsers.fParser[ndx].Reader;

    result := true;

  end else

    result := false;

end;



function TJSONCustomParsers.DynArraySearch(aDynArrayTypeInfo,aRecordTypeInfo: pointer;

  out Writer: TDynArrayJSONCustomWriter; PParser: PTJSONCustomParserAbstract): boolean;

var ndx: integer;

begin

  ndx := DynArraySearch(aDynArrayTypeInfo,aRecordTypeInfo);

  if (ndx>=0) and Assigned(GlobalJSONCustomParsers.fParser[ndx].Writer) then begin

    Writer := GlobalJSONCustomParsers.fParser[ndx].Writer;

    if PParser<>nil then

      PParser^ := GlobalJSONCustomParsers.fParser[ndx].RecordCustomParser;

    result := true;

  end else

    result := false;

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)<cardinal(fParsersCount)) and

       (fParser[fLastRecordIndex].RecordTypeInfo=aRecordTypeInfo) then begin

      result := fLastRecordIndex;

      exit;

    end else

    for result := 0 to fParsersCount-1 do

      if fParser[result].RecordTypeInfo=aRecordTypeInfo then begin

        fLastRecordIndex := result;

        exit;

      end;

  if AddIfNotExisting then begin

    result := TryToGetFromRTTI(nil,aRecordTypeInfo);

    if result>=0 then

      GlobalJSONCustomParsers.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)<cardinal(fParsersCount)) and

       IdemPropNameU(fParser[fLastRecordIndex].RecordTypeName,aTypeName) then

      result := fLastRecordIndex else begin

      result := fParsers.FindHashed(aTypeName);

      if result>=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(GlobalJSONCustomParsers.fParser[ndx].Reader) then begin

    Reader := GlobalJSONCustomParsers.fParser[ndx].Reader;

    result := true;

  end else

    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(GlobalJSONCustomParsers.fParser[ndx].Writer) then begin

    Writer := GlobalJSONCustomParsers.fParser[ndx].Writer;

    if PParser<>nil then

      PParser^ := GlobalJSONCustomParsers.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(kind=%) not DynArray or Record',

    [self,PByte(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;



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(aTypeInfo,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 RecordSaveJSON(const Rec; TypeInfo: pointer; EnumSetsAsText: boolean): RawUTF8;

begin

  SaveJSON(Rec,TypeInfo,EnumSetsAsText,result);

end;



const

  NULCHAR: AnsiChar = #0;



function RecordLoadJSON(var Rec; JSON: PUTF8Char; TypeInfo: pointer;

  EndOfObject: PUTF8Char=nil): PUTF8Char;

var wasString, wasValid: boolean;

    Reader: TDynArrayJSONCustomReader;

    EndOfObj: AnsiChar;

    Val: PUTF8Char;

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)^,PByte(TypeInfo)^]);

    Val := GetJSONField(JSON,JSON,@wasString,@EndOfObj);

    if (Val=nil) or (not wasString) or

       (PInteger(Val)^ and $00ffffff<>JSON_BASE64_MAGIC) or

       (RecordLoad(Rec,pointer(Base64ToBin(Val+3)),TypeInfo)=nil) then

      exit; // invalid content

  end else begin

    if not GlobalJSONCustomParsers.RecordSearch(TypeInfo,Reader) then

      exit;

    JSON := Reader(JSON,Rec,wasValid);

    if not wasValid then

      exit;

    if (JSON<>nil) and (JSON^ in [#1..' ']) then

      repeat inc(JSON) until not(JSON^ in [#1..' ']);

    if (JSON<>nil) and (JSON^<>#0) then begin

      EndOfObj := JSON^;

      inc(JSON);

    end else

      EndOfObj := #0;

  end;

  if JSON=nil then

    result := @NULCHAR else

    result := JSON;

  if EndOfObject<>nil then

    EndOfObject^ := EndOfObj;

end;



function RecordLoadJSON(var Rec; const JSON: RawUTF8; TypeInfo: pointer): boolean;

var tmp: TSynTempBuffer;

begin

  tmp.Init(JSON);

  try

    result := RecordLoadJSON(Rec,tmp.buf,TypeInfo)<>nil;

  finally

    tmp.Done;

  end;

end;





{ TJSONCustomParserCustom }



constructor TJSONCustomParserCustom.Create(const aPropertyName, aCustomTypeName: RawUTF8);

begin

  inherited Create(aPropertyName,ptCustom);

  fCustomTypeName := aCustomTypeName;

end;



procedure TJSONCustomParserCustom.FinalizeItem(Data: Pointer);

begin // nothing to be done by default

end;





{ TJSONCustomParserCustomSimple }



constructor TJSONCustomParserCustomSimple.Create(

  const aPropertyName, aCustomTypeName: RawUTF8; aCustomType: pointer);

var info: PTypeInfo;

    kind: TTypeKind;

begin

  inherited Create(aPropertyName,aCustomTypeName);

  fCustomTypeInfo := aCustomType;

  if IdemPropNameU(aCustomTypeName,'TGUID') then begin

    fKnownType := ktGUID;

    fDataSize := sizeof(TGUID);

  end else

  if fCustomTypeInfo<>nil then begin

    TypeInfoToName(fCustomTypeInfo,fCustomTypeName,aCustomTypeName);

    kind := PTypeKind(fCustomTypeInfo)^;

    info := GetTypeInfo(fCustomTypeInfo,[tkEnumeration,tkSet,tkArray,tkDynArray]);

    fTypeData := info;

    if info<>nil then

    case kind of

    tkEnumeration, tkSet: begin

      case info^.EnumType of

        otSByte,otUByte: fDataSize := 1;

        otSWord,otUWord: fDataSize := 2;

        otSLong,otULong: fDataSize := 4;

      end;

      if kind=tkEnumeration then

        fKnownType := ktEnumeration else

        fKnownType := ktSet;

      exit; // success

    end;

    tkArray: begin

      if info^.dimCount<>1 then

        raise ESynException.CreateUTF8(

          '%.Create("%") supports only one dimension static array)',

          [self,fCustomTypeName]);

      fKnownType := ktStaticArray;

      fDataSize := info^.arraySize;

      fFixedSize := fDataSize div info^.elCount;

      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;



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,

      twoEnumSetsAsTextInRecord in aWriter.CustomOptions, true);

  ktDynamicArray:

    raise ESynException.CreateUTF8('%.CustomWriter("%"): Unsupported',

        [self,fCustomTypeName]);

  else begin // encoded as JSON strings

    aWriter.Add('"');

    case fKnownType of

    ktGUID:

      aWriter.Add(TGUID(aValue));

    ktFixedArray:

      aWriter.AddBinToHex(@aValue,fFixedSize);

    end;

    aWriter.Add('"');

  end;

  end;

end;



function TJSONCustomParserCustomSimple.CustomReader(P: PUTF8Char;

  var aValue; out EndOfObject: AnsiChar): PUTF8Char;

var PropValue: PUTF8Char;

    i,i32: integer;

    wasString: boolean;

    Val: PByte;

begin

  result := nil; // indicates error

  case fKnownType of

  ktStaticArray: begin

    if P^<>'[' then

      exit; // we expect a true array here

    P := GotoNextNotSpace(P+1);

    if JSONArrayCount(P)<>PTypeInfo(fTypeData)^.elCount then

      exit; // invalid number of items

    Val := @aValue;

    for i := 1 to PTypeInfo(fTypeData)^.elCount do

      if not fNestedArray.ReadOneLevel(P,Val,[]) then

        exit else

      if P=nil then

        exit;

    P := GotoNextNotSpace(P);

    EndOfObject := P^;

    if P^ in [',','}'] then

      inc(P);

    result := P;

  end;

  ktDynamicArray:

    raise ESynException.CreateUTF8('%.CustomReader("%"): Unsupported',

        [self,fCustomTypeName]);

  ktSet: begin

    i32 := GetSetNameValue(fCustomTypeInfo,P,EndOfObject);

    MoveFast(i32,aValue,fDataSize);

    result := P;

  end;

  else begin // encoded as JSON strings

    PropValue := GetJSONField(P,P,@wasString,@EndOfObject);

    if PropValue=nil then

      exit;

    if P=nil then

      P := @NULCHAR; // result=nil indicates error

    case fKnownType of

    ktGUID:

      if wasString and (TextToGUID(PropValue,@aValue)<>nil) then

        result := P;

    ktEnumeration: begin

      if wasString then

        i32 := GetEnumNameValue(fCustomTypeInfo,PropValue,StrLen(PropValue),true) else

        i32 := GetCardinal(PropValue);

      if i32<0 then

        exit;

      MoveFast(i32,aValue,fDataSize);

      result := P;

    end;

    ktFixedArray:

      if wasString and (StrLen(PropValue)=fFixedSize*2) and

         SynCommons.HexToBin(PAnsiChar(PropValue),@aValue,fFixedSize) then

        result := P;

    end;

  end;

  end;

end;





{ TJSONCustomParserCustomRecord }



{constructor TJSONCustomParserCustomRecord.Create(

  const aPropertyName, aCustomTypeName: RawUTF8);

begin

  inherited Create(aPropertyName,aCustomTypeName);

  fCustomTypeIndex := GlobalJSONCustomParsers.RecordSearch(aCustomTypeName);

  if fCustomTypeIndex<0 then

    raise ESynException.CreateUTF8('%.Create(unknown "%" type)',

      [self,aCustomTypeName]);

  with GlobalJSONCustomParsers.fParser[fCustomTypeIndex] do begin

    fCustomTypeInfo := RecordTypeInfo;

    fCustomTypeName := RecordTypeName;

  end;

  fDataSize := RecordTypeInfoSize(fCustomTypeInfo);

  if fDataSize=0 then

    raise ESynException.CreateUTF8('%.Create("%" non record type)',

      [self,aCustomTypeName]);

end;}



constructor TJSONCustomParserCustomRecord.Create(

  const aPropertyName: RawUTF8; aCustomTypeIndex: integer);

begin

  fCustomTypeIndex := aCustomTypeIndex;

  with GlobalJSONCustomParsers.fParser[fCustomTypeIndex] do begin

    inherited Create(aPropertyName,RecordTypeName);

    fCustomTypeInfo := RecordTypeInfo;

    fCustomTypeName := RecordTypeName;

  end;

  fDataSize := RecordTypeInfoSize(fCustomTypeInfo);

end;



function TJSONCustomParserCustomRecord.GetJSONCustomParserRegistration: pointer;

begin

  result := nil;

  if GlobalJSONCustomParsers<>nil then begin

    if (Cardinal(fCustomTypeIndex)>=Cardinal(GlobalJSONCustomParsers.fParsersCount)) or

       not IdemPropNameU(fCustomTypeName,

         GlobalJSONCustomParsers.fParser[fCustomTypeIndex].RecordTypeName) then

      fCustomTypeIndex := GlobalJSONCustomParsers.RecordSearch(fCustomTypeInfo);

    if fCustomTypeIndex>=0 then

      result := @GlobalJSONCustomParsers.fParser[fCustomTypeIndex];

  end;

  if result=nil then

    raise ESynException.CreateUTF8(

      '%: "%" type should not have been un-registered',[self,fCustomTypeName]);

end;



procedure TJSONCustomParserCustomRecord.CustomWriter(

  const aWriter: TTextWriter; const aValue);

var parser: PJSONCustomParserRegistration;

begin

  parser := GetJSONCustomParserRegistration;

  parser^.Writer(aWriter,aValue);

end;



function TJSONCustomParserCustomRecord.CustomReader(P: PUTF8Char;

  var aValue; out EndOfObject: AnsiChar): PUTF8Char;

var valid: boolean;

    callback: PJSONCustomParserRegistration; // D5/D6 Internal error: C3890

begin

  callback := GetJSONCustomParserRegistration;

  result := callback^.Reader(P,aValue,valid);

  if not valid then

    result := nil;

  if result=nil then

    exit;

  EndOfObject := result^;

  if result^ in [',','}',']'] then

    inc(result);

end;



procedure TJSONCustomParserCustomRecord.FinalizeItem(Data: Pointer);

begin

  RecordClear(Data^,fCustomTypeInfo);

end;





{ TJSONCustomParserRTTI }



var

  GlobalCustomJSONSerializerFromTextSimpleType_: TRawUTF8ListHashed;



function GlobalCustomJSONSerializerFromTextSimpleType: TRawUTF8ListHashed;

begin

  if GlobalCustomJSONSerializerFromTextSimpleType_=nil then begin

    GarbageCollectorFreeAndNil(GlobalCustomJSONSerializerFromTextSimpleType_,

      TRawUTF8ListHashed.Create(false));

    GlobalCustomJSONSerializerFromTextSimpleType_.CaseSensitive := false;

    GlobalCustomJSONSerializerFromTextSimpleType_.AddObjectIfNotExisting(

      'TGUID',{$ifdef ISDELPHI2010}TypeInfo(TGUID){$else}nil{$endif});

  end;

  result := GlobalCustomJSONSerializerFromTextSimpleType_;

end;



/// if defined, will try to mimic the default record alignment

// -> is buggy, and compiler revision specific -> we would rather use packed records

{.$define ALIGNCUSTOMREC}



constructor TJSONCustomParserRTTI.Create(const aPropertyName: RawUTF8;

  aPropertyType: TJSONCustomParserRTTIType);

begin

  fPropertyName := aPropertyName;

  fPropertyType := aPropertyType;

end;



class function TJSONCustomParserRTTI.TypeNameToSimpleRTTIType(TypeName: PUTF8Char;

  TypeNameLen: Integer; var ItemTypeName: RawUTF8): TJSONCustomParserRTTIType;

const

  SORTEDMAX = {$ifdef NOVARIANTS}30{$else}31{$endif};

  SORTEDNAMES: array[0..SORTEDMAX] of PUTF8Char =

    ('ARRAY','BOOLEAN','BYTE','CARDINAL','CURRENCY',

     'DOUBLE','EXTENDED','INT64','INTEGER','PTRINT','PTRUINT',

     'RAWBYTESTRING','RAWJSON','RAWUTF8','RECORD','SINGLE',

     'STRING','SYNUNICODE','TCREATETIME','TDATETIME','TGUID',

     'TID','TMODTIME','TRECORDREFERENCE','TRECORDREFERENCETOBEDELETED',

     'TRECORDVERSION','TSQLRAWBLOB','TTIMELOG','UTF8STRING',

     {$ifndef NOVARIANTS}'VARIANT',{$endif}

     'WIDESTRING','WORD');

   // warning: recognized types should match at binary storage level!

   SORTEDTYPES: array[0..SORTEDMAX] of TJSONCustomParserRTTIType =

     (ptArray,ptBoolean,ptByte,ptCardinal,ptCurrency,

      ptDouble,ptExtended,ptInt64,ptInteger,ptPtrInt,ptPtrUInt,

      ptRawByteString,ptRawJSON,ptRawUTF8,ptRecord,ptSingle,

      ptString,ptSynUnicode,ptTimeLog,ptDateTime,ptGUID,

      ptID,ptTimeLog,ptInt64,ptInt64,

      ptInt64,ptRawByteString,ptTimeLog,ptRawUTF8,

      {$ifndef NOVARIANTS}ptVariant,{$endif}

      ptWideString,ptWord);

var ndx: integer;

begin

  UpperCaseCopy(TypeName,TypeNameLen,ItemTypeName);

//for ndx := 1 to SORTEDMAX do assert(StrComp(SORTEDNAMES[ndx],SORTEDNAMES[ndx-1])>0,SORTEDNAMES[ndx]);

  ndx := FastFindPUTF8CharSorted(@SORTEDNAMES,SORTEDMAX,pointer(ItemTypeName));

  if ndx>=0 then

    result := SORTEDTYPES[ndx] else

    result := ptCustom;

end;



class function TJSONCustomParserRTTI.TypeNameToSimpleRTTIType(

  const TypeName: RawUTF8): TJSONCustomParserRTTIType;

var ItemTypeName: RawUTF8;

begin

  if TypeName='' then

    result := ptCustom else

    result := TypeNameToSimpleRTTIType(Pointer(TypeName),length(TypeName),ItemTypeName);

end;



class function TJSONCustomParserRTTI.TypeNameToSimpleRTTIType(

  TypeName: PShortString): TJSONCustomParserRTTIType;

var ItemTypeName: RawUTF8;

begin

  if TypeName=nil then

    result := ptCustom else

    result := TypeNameToSimpleRTTIType(@TypeName^[1],Ord(TypeName^[0]),ItemTypeName);

end;



class function TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(Info: pointer;

  ItemSize: integer): TJSONCustomParserRTTIType;

begin

  result := ptCustom;

  if Info=nil then

    exit;

  case PTypeKind(Info)^ of

  tkLString{$ifdef FPC},tkLStringOld{$endif}: result := ptRawUTF8;

  tkWString: result := ptWideString;

  {$ifdef UNICODE}

  tkUString: result := ptSynUnicode;

  tkClassRef, tkPointer, tkProcedure:

    case ItemSize of

    1: result := ptByte;

    2: result := ptWord;

    4: result := ptCardinal;

    8: result := ptInt64;

    else result := ptPtrInt;

    end;

  {$endif}

  {$ifndef NOVARIANTS}

  tkVariant: result := ptVariant;

  {$endif}

  tkDynArray: result := ptArray;

  tkChar: result := ptByte;

  tkWChar: result := ptWord;

  tkClass, tkMethod, tkInterface: result := ptPtrInt;

  tkInteger, tkSet:

    case GetTypeInfo(Info,[tkInteger,tkSet])^.IntegerType of

    otSByte,otUByte: result := ptByte;

    otSWord,otUWord: result := ptWord;

    otSLong: result := ptInteger;

    otULong: result := ptCardinal;

    end;

  tkInt64: result := ptInt64;

  {$ifdef FPC}

  tkBool: result := ptBoolean;

  {$else}

  tkEnumeration:

    if Info=TypeInfo(boolean) then

      result := ptBoolean;

      // other enumerates will use TJSONCustomParserCustomSimple below

  {$endif}

  tkFloat:

    case GetTypeInfo(Info,tkFloat)^.FloatType of

    ftSingle:   result := ptSingle;

    ftDoub:     result := ptDouble;

    ftCurr:     result := ptCurrency;

    ftExtended: result := ptExtended;

    // ftComp: not implemented yet

    end;

  end;

end;



class function TJSONCustomParserRTTI.CreateFromRTTI(

  const PropertyName: RawUTF8; Info: pointer; ItemSize: integer): TJSONCustomParserRTTI;

var Item: PTypeInfo absolute Info;

    ItemType: TJSONCustomParserRTTIType;

    ItemTypeName: RawUTF8;

    ndx: integer;

begin

  if Item=nil then // no RTTI -> stored as hexa string

    result := TJSONCustomParserCustomSimple.CreateFixedArray(PropertyName,ItemSize) else begin

    ItemType := TypeNameToSimpleRTTIType(PUTF8Char(@Item.NameLen)+1,Item.NameLen,ItemTypeName);

    if ItemType=ptCustom then

      ItemType := TypeInfoToSimpleRTTIType(Info,ItemSize);

    if ItemType=ptCustom then

      if Item^.kind in [tkEnumeration,tkArray,tkDynArray] 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("%")',

            [self,ItemTypeName]);

        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;

begin

  ndx := GlobalCustomJSONSerializerFromTextSimpleType.IndexOf(aCustomRecordTypeName);

  if ndx>=0 then

    result := TJSONCustomParserCustomSimple.Create(

      aPropertyName,aCustomRecordTypeName,

      GlobalCustomJSONSerializerFromTextSimpleType_.Objects[ndx]) 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: integer;

begin

  for i := 0 to high(NestedProperty) do begin

    NestedProperty[i].ComputeFullPropertyName;

    if fFullPropertyName<>'' then

      NestedProperty[i].fFullPropertyName :=

        fFullPropertyName+'.'+NestedProperty[i].fPropertyName;

  end;

end;



procedure TJSONCustomParserRTTI.ComputeNestedDataSize;

var i: integer;

begin

  assert(fNestedDataSize=0);

  fNestedDataSize := 0;

  for i := 0 to high(NestedProperty) do begin

    NestedProperty[i].ComputeDataSizeAfterAdd;

    inc(fNestedDataSize,NestedProperty[i].fDataSize);

    if fFullPropertyName<>'' then

      NestedProperty[i].fFullPropertyName :=

        fFullPropertyName+'.'+NestedProperty[i].fPropertyName;

  end;

end;



procedure TJSONCustomParserRTTI.ComputeDataSizeAfterAdd;

const // binary size (in bytes) of each kind of property - 0 for ptRecord/ptCustom

  JSONRTTI_SIZE: array[TJSONCustomParserRTTIType] of byte = (

    SizeOf(PtrUInt),SizeOf(Boolean),SizeOf(Byte),SizeOf(Cardinal),SizeOf(Currency),

    SizeOf(Double),SizeOf(Extended),SizeOf(Int64),SizeOf(Integer),SizeOf(RawByteString),

    SizeOf(RawJSON),SizeOf(RawUTF8),0,SizeOf(Single),SizeOf(String),SizeOf(SynUnicode),

    SizeOf(TDateTime),SizeOf(TGUID),SizeOf(Int64),SizeOf(TTimeLog),

    {$ifndef NOVARIANTS}SizeOf(Variant),{$endif}

    SizeOf(WideString),SizeOf(Word),0);

var i: integer;

begin

  if fFullPropertyName='' then begin

    fFullPropertyName := fPropertyName;

    ComputeFullPropertyName;

  end;

  if fDataSize=0 then begin

    ComputeNestedDataSize;

    case PropertyType of

    ptRecord:

      for i := 0 to high(NestedProperty) do

        inc(fDataSize,NestedProperty[i].fDataSize);

    //ptCustom: fDataSize already set in TJSONCustomParserCustom.Create()

    else

      fDataSize := JSONRTTI_SIZE[PropertyType];

    end;

    {$ifdef ALIGNCUSTOMREC}

    inc(fDataSize,fDataSize and 7);

    {$endif}

  end;

end;



procedure TJSONCustomParserRTTI.FinalizeNestedRecord(var Data: PByte);

var j: integer;

begin

  for j := 0 to high(NestedProperty) do begin

    case NestedProperty[j].PropertyType of

    ptRawByteString,

    ptRawJSON,

    ptRawUTF8:    PRawByteString(Data)^ := '';

    ptString:     PString(Data)^ := '';

    ptSynUnicode: PSynUnicode(Data)^ := '';

    ptWideString: PWideString(Data)^ := '';

    ptArray:      NestedProperty[j].FinalizeNestedArray(PPtrUInt(Data)^);

    {$ifndef NOVARIANTS}

    ptVariant:    VarClear(PVariant(Data)^);

    {$endif}

    ptRecord: begin

      NestedProperty[j].FinalizeNestedRecord(Data);

      continue;

    end;

    ptCustom:

      TJSONCustomParserCustom(NestedProperty[j]).FinalizeItem(Data);

    end;

    inc(Data,NestedProperty[j].fDataSize);

  end;

end;



procedure TJSONCustomParserRTTI.FinalizeNestedArray(var Data: PtrUInt);

var i: integer;

    Rec: ^TDynArrayRec;

    ItemData: PByte;

begin

  if Data=0 then

    exit;

  ItemData := pointer(Data);

  Rec := pointer(Data);

  dec(PtrUInt(Rec),sizeof(TDynArrayRec));

  for i := 0 to Rec.length-1 do

    FinalizeNestedRecord(ItemData);

  FreeMem(Rec);

  Data := 0;

end;



procedure TJSONCustomParserRTTI.AllocateNestedArray(var Data: PtrUInt;

  NewLength: integer);

begin

  FinalizeNestedArray(Data);

  if NewLength<=0 then

    exit;

  pointer(Data) := AllocMem(sizeof(TDynArrayRec)+fNestedDataSize*NewLength);

  PDynArrayRec(Data)^.refCnt := 1;

  PDynArrayRec(Data)^.length := NewLength;

  inc(Data,sizeof(TDynArrayRec));

end;



procedure TJSONCustomParserRTTI.ReAllocateNestedArray(var Data: PtrUInt;

  NewLength: integer);

var OldLength: integer;

begin

  if Data=0 then

    raise ESynException.CreateUTF8('%.ReAllocateNestedArray(nil)',[self]);

  dec(Data,sizeof(TDynArrayRec));

  ReAllocMem(pointer(Data),sizeof(TDynArrayRec)+fNestedDataSize*NewLength);

  OldLength := PDynArrayRec(Data)^.length;

  if NewLength>OldLength then

    FillcharFast(PByteArray(Data)[sizeof(TDynArrayRec)+fNestedDataSize*OldLength],

      fNestedDataSize*(NewLength-OldLength),0);

  PDynArrayRec(Data)^.length := NewLength;

  inc(Data,sizeof(TDynArrayRec));

end;



function TJSONCustomParserRTTI.ReadOneLevel(var P: PUTF8Char; var Data: PByte;

  Options: TJSONCustomParserSerializationOptions): boolean;

var EndOfObject: AnsiChar;

  function ProcessValue(const Prop: TJSONCustomParserRTTI; var P: PUTF8Char;

    var Data: PByte): boolean;

  var DynArray: PByte;

      ArrayLen, ArrayCapacity, n: integer;

      wasString: boolean;

      PropValue, ptr: PUTF8Char;

  label Error;

  begin

    result := false;

    P := GotoNextNotSpace(P);

    case Prop.PropertyType of

    ptRecord: begin

      if not Prop.ReadOneLevel(P,Data,Options) then

        exit;

      EndOfObject := P^;

      if P^ in [',','}'] then

        inc(P);

      result := true;

      exit;

    end;

    ptArray:

    if PInteger(P)^=NULL_LOW then begin // null -> void array

      P := GotoNextNotSpace(P+4);

      EndOfObject := P^;

      if P^<>#0 then //if P^=',' then

        inc(P);

      Prop.FinalizeNestedArray(PPtrUInt(Data)^);

    end else begin

      if P^<>'[' then

        exit; // we expect a true array here

      repeat inc(P) until P^<>' ';

      // try to allocate nested array at once (if not too slow)

      ArrayLen := JSONArrayCount(P,P+131072); // parse up to 128 KB here

      if ArrayLen<0 then // mostly JSONArrayCount()=nil due to PMax -> 512

        ArrayCapacity := 512 else

        ArrayCapacity := ArrayLen;

      Prop.AllocateNestedArray(PPtrUInt(Data)^,ArrayCapacity);

      // read array content

      if ArrayLen=0 then begin

        if not NextNotSpaceCharIs(P,']') then

          exit;

      end else begin

        n := 0;

        DynArray := PPointer(Data)^;

        repeat

          inc(n);

          if (ArrayLen<0) and (n>ArrayCapacity) then begin

            inc(ArrayCapacity,512+ArrayCapacity shr 3);

            Prop.ReAllocateNestedArray(PPtrUInt(Data)^,ArrayCapacity);

            DynArray := PPointer(Data)^;

            inc(DynArray,pred(n)*Prop.fNestedDataSize);

          end;

          if Prop.NestedProperty[0].PropertyName='' then begin

            // array of simple type

            ptr := P;

            if not ProcessValue(Prop.NestedProperty[0],ptr,DynArray) or (ptr=nil) then

              goto Error;

            P := ptr;

          end else begin

            // array of record

            ptr := P;

            if not Prop.ReadOneLevel(ptr,DynArray,Options) or (ptr=nil) then

              goto Error;

            P := GotoNextNotSpace(ptr);

            EndOfObject := P^;

            if not(P^ in [',',']']) then

              goto Error;

            inc(P);

          end;

          case EndOfObject of

          ',': continue;

          ']': begin

            if ArrayLen<0 then

              Prop.ReAllocateNestedArray(PPtrUInt(Data)^,n) else

              if n<>ArrayLen then

                goto Error;

            break; // we reached end of array

          end;

          else begin

Error:      Prop.FinalizeNestedArray(PPtrUInt(Data)^);

            exit;

           end;

          end;

        until false;

      end;

      if P=nil then

        exit;

      P := GotoNextNotSpace(P);

      EndOfObject := P^;

      if P^<>#0 then //if P^=',' then

        inc(P);

    end;

    ptCustom: begin                                  

      ptr := TJSONCustomParserCustom(Prop).CustomReader(P,Data^,EndOfObject);

      if ptr=nil then

        exit;

      P := ptr;

    end;

    {$ifndef NOVARIANTS}

    ptVariant:

      P := VariantLoadJSON(PVariant(Data)^,P,@EndOfObject,

        @JSON_OPTIONS[soCustomVariantCopiedByReference in Options]);

    {$endif}

    ptRawByteString: begin

      PropValue := GetJSONField(P,ptr,@wasString,@EndOfObject);

      if PropValue=nil then // null -> Blob=''

        PRawByteString(Data)^ := '' else

        if not Base64MagicCheckAndDecode(PropValue,PRawByteString(Data)^) then

          exit;

      P := ptr;

    end;

    ptRawJSON:

      GetJSONItemAsRawJSON(P,PRawJSON(Data)^,@EndOfObject);

    else begin

      PropValue := GetJSONField(P,ptr,@wasString,@EndOfObject);

      if (PropValue<>nil) and // PropValue=nil for null

         (wasString<>(Prop.PropertyType in [ptRawUTF8,ptString,

           ptSynUnicode,ptDateTime,ptGUID,ptWideString])) then

         exit;

      P := ptr;

      case Prop.PropertyType of

      ptBoolean:   PBoolean(Data)^ := GetBoolean(PropValue);

      ptByte:      PByte(Data)^ := GetCardinal(PropValue);

      ptCardinal:  PCardinal(Data)^ := GetCardinal(PropValue);

      ptCurrency:  PInt64(Data)^ := StrToCurr64(PropValue);

      ptDouble:    PDouble(Data)^ := GetExtended(PropValue);

      ptExtended:  PExtended(Data)^ := GetExtended(PropValue);

      ptInt64,ptID,ptTimeLog: SetInt64(PropValue,PInt64(Data)^);

      ptInteger:   PInteger(Data)^ := GetInteger(PropValue);

      ptSingle:    PSingle(Data)^ := GetExtended(PropValue);

      ptRawUTF8:   PRawUTF8(Data)^ := PropValue;

      ptString:    UTF8DecodeToString(PropValue,StrLen(PropValue),PString(Data)^);

      ptSynUnicode:UTF8ToSynUnicode(PropValue,StrLen(PropValue),PSynUnicode(Data)^);

      ptDateTime:  Iso8601ToDateTimePUTF8CharVar(PropValue,0,PDateTime(Data)^);

      ptWideString:UTF8ToWideString(PropValue,StrLen(PropValue),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 then begin // a record stored as null

    P := GotoNextNotSpace(P+4);

    inc(Data,fDataSize);

    result := true;

    exit;

  end;

  if not (PropertyType in [ptRecord,ptArray]) then begin

    result := ProcessValue(Self,P,Data);

    exit;

  end;

  if P^<>'{' then

    exit; // we expect a true object here

  repeat inc(P) until not(P^ in [#1..' ']);

  if P^='}' then begin

    inc(Data,fDataSize);

    EndOfObject := '}';

    inc(P);

  end else

  for i := 0 to High(NestedProperty) 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 high(NestedProperty) 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 High(NestedProperty) 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 high(NestedProperty) do

        if Values[j]=nil then // ignore missing properties

          inc(Data,NestedProperty[j].fDataSize) else

          if not ProcessValue(NestedProperty[j],Values[j],Data) then

            exit;

      EndOfObject := '}'; // ProcessValue() did update EndOfObject

      break;

    end;

  end;

  if (P<>nil) and (EndOfObject=',') and (soReadIgnoreUnknownFields in Options) then begin

    ptr := GotoNextJSONObjectOrArray(P,'}');

    if ptr=nil then

      exit;

    P := ptr;

  end else

    if EndOfObject<>'}' then

      exit;

  if P<>nil then

    P := GotoNextNotSpace(P);

  result := true;

end;



procedure JSONBoolean(value: boolean; var result: RawUTF8);

begin // defined as a function and not an array[boolean] of RawUTF8 for FPC

  if value then

    result := 'true' else

    result := 'false';

end;



procedure TJSONCustomParserRTTI.WriteOneLevel(aWriter: TTextWriter; var P: PByte;

  Options: TJSONCustomParserSerializationOptions);

  procedure WriteOneValue(Prop: TJSONCustomParserRTTI; var Value: PByte);

  var DynArray: PByte;

      j: integer;

  begin

    case Prop.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)^);

    ptInteger:   aWriter.Add(PInteger(Value)^);

    ptSingle:    aWriter.AddSingle(PSingle(Value)^);

    ptWord:      aWriter.AddU(PWord(Value)^);

    {$ifndef NOVARIANTS}

    ptVariant:   aWriter.AddVariant(PVariant(Value)^,twJSONEscape);

    {$endif}

    ptRawByteString:

      aWriter.WrBase64(PPointer(Value)^,length(PRawByteString(Value)^),true);

    ptRawJSON, ptRawUTF8, ptString, ptSynUnicode,

    ptDateTime, ptGUID, ptWideString: begin

      aWriter.Add('"');

      case Prop.PropertyType of

      ptRawJSON:       aWriter.AddNoJSONEscape(PPointer(Value)^,length(PRawJSON(Value)^));

      ptRawUTF8:       aWriter.AddJSONEscape(PPointer(Value)^);

      ptString:        aWriter.AddJSONEscapeString(PString(Value)^);

      ptSynUnicode,

      ptWideString:    aWriter.AddJSONEscapeW(PPointer(Value)^);

      ptDateTime:      aWriter.AddDateTime(unaligned(PDateTime(Value)^));

      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 Prop.NestedProperty[0].PropertyName='' then  // array of simple

            WriteOneValue(Prop.NestedProperty[0],DynArray) else

            Prop.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

      Prop.WriteOneLevel(aWriter,Value,Options);

      exit;

    end;

    ptCustom:

      TJSONCustomParserCustom(Prop).CustomWriter(aWriter,Value^);

    end;

    inc(Value,Prop.fDataSize);

  end;

var i: integer;

    SubProp: TJSONCustomParserRTTI;

begin

  if P=nil then begin

    aWriter.AddShort('null');

    exit;

  end;

  if not (PropertyType in [ptRecord,ptArray]) then begin

    WriteOneValue(self,P);

    exit;

  end;

  aWriter.Add('{');

  Inc(aWriter.fHumanReadableLevel);

  for i := 0 to high(NestedProperty) do begin

    SubProp := NestedProperty[i];

    if soWriteHumanReadable in Options then

      aWriter.AddCRAndIndent;

    aWriter.AddFieldName(SubProp.PropertyName);

    if soWriteHumanReadable in Options then

      aWriter.Add(' ');

    WriteOneValue(SubProp,P);

    aWriter.Add(',');

  end;

  aWriter.CancelLastComma;

  dec(aWriter.fHumanReadableLevel);

  if soWriteHumanReadable in Options then

    aWriter.AddCRAndIndent;

  aWriter.Add('}');

end;





{ TJSONRecordAbstract }



constructor TJSONRecordAbstract.Create;

begin

  fItems := TObjectList.Create;

end;



function TJSONRecordAbstract.AddItem(const aPropertyName: RawUTF8;

  aPropertyType: TJSONCustomParserRTTIType;

  const aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI;

begin

  if aPropertyType=ptCustom then begin

    result := TJSONCustomParserRTTI.CreateFromTypeName(

      aPropertyName,aCustomRecordTypeName);

    if result=nil then

      raise ESynException.CreateUTF8('Unregistered ptCustom for %.AddItem(%: %)',

        [self,aPropertyName,aCustomRecordTypeName]);

  end else

    result := TJSONCustomParserRTTI.Create(aPropertyName,aPropertyType);

  fItems.Add(result);

end;



function TJSONRecordAbstract.CustomReader(P: PUTF8Char; var aValue; out aValid: Boolean): PUTF8Char;

var Data: PByte;

begin

  Data := @aValue;

  aValid := Root.ReadOneLevel(P,Data,Options);

  result := P;

end;



procedure TJSONRecordAbstract.CustomWriter(const aWriter: TTextWriter; const aValue);

var P: PByte;

begin

  P := @aValue;

  Root.WriteOneLevel(aWriter,P,Options);

end;



destructor TJSONRecordAbstract.Destroy;

begin

  FreeAndNil(fItems);

  inherited;

end;





{ TJSONRecordTextDefinition }



var

  JSONCustomParserCache: TRawUTF8ListHashed;



class function TJSONRecordTextDefinition.FromCache(aTypeInfo: pointer;

  const aDefinition: RawUTF8): TJSONRecordTextDefinition;

var i: integer;

    added: boolean;

begin

  if JSONCustomParserCache=nil then

    GarbageCollectorFreeAndNil(JSONCustomParserCache,TRawUTF8ListHashed.Create(True));

  i := JSONCustomParserCache.AddObjectIfNotExisting(aDefinition,nil,@added);

  if not added then begin

    result := TJSONRecordTextDefinition(JSONCustomParserCache.fObjects[i]);

    exit;

  end;

  result := TJSONRecordTextDefinition.Create(aTypeInfo,aDefinition);

  JSONCustomParserCache.fObjects[i] := result;

end;



constructor TJSONRecordTextDefinition.Create(aRecordTypeInfo: pointer;

  const aDefinition: RawUTF8);

var P: PUTF8Char;

    recordInfoSize: integer;

begin

  inherited Create;

  fDefinition := aDefinition;

  fRoot := TJSONCustomParserRTTI.Create('',ptRecord);

  TypeInfoToName(aRecordTypeInfo,fRoot.fCustomTypeName);

  fItems.Add(fRoot);

  P := pointer(aDefinition);

  Parse(fRoot,P,eeNothing);

  fRoot.ComputeDataSizeAfterAdd;

  recordInfoSize := RecordTypeInfoSize(aRecordTypeInfo);

  if (recordInfoSize<>0) and (fRoot.fDataSize<>recordInfoSize) then

    raise ESynException.CreateUTF8('%.Create: % text definition is not accurate,'+

      ' or the type has not been defined as PACKED record: RTTI size is %'+

      ' bytes but text definition generated % bytes',

      [self,fRoot.fCustomTypeName,recordInfoSize,fRoot.fDataSize]);

end;



procedure TJSONRecordTextDefinition.Parse(Props: TJSONCustomParserRTTI;

  var P: PUTF8Char; PEnd: TJSONCustomParserRTTIExpectedEnd);

const DYNARRAYTEXT: PUTF8Char = 'DynArray'; // make Delphi 5 compiler happy

  function GetNextFieldType(var P: PUTF8Char;

    var TypIdent: RawUTF8): TJSONCustomParserRTTIType;

  begin

    if GetNextFieldProp(P,TypIdent) then

      result := TJSONCustomParserRTTI.TypeNameToSimpleRTTIType(

        pointer(TypIdent),length(TypIdent),TypIdent) else

      raise ESynException.CreateUTF8('%.Parse: missing field type',[self]);

  end;

var PropsName: TRawUTF8DynArray;

    PropsMax, ndx, len, firstNdx: cardinal;

    Typ, ArrayTyp: TJSONCustomParserRTTIType;

    TypIdent, ArrayTypIdent: RawUTF8;

    Item: TJSONCustomParserRTTI;

    ExpectedEnd: TJSONCustomParserRTTIExpectedEnd;

begin

  SetLength(PropsName,16);

  PropsMax := 0;

  while (P<>nil) and (P^<>#0) do begin

    // fill Props[]

    if not GetNextFieldProp(P,PropsName[PropsMax]) then

      break;

    case P^ of

    ',': begin

      inc(P);

      inc(PropsMax);

      if PropsMax=cardinal(length(PropsName)) then

        SetLength(PropsName,PropsMax+16);

      continue; // several properties defined with the same type

    end;

    ':': P := GotoNextNotSpace(P+1);

    end;

    // identify type

    ArrayTyp := ptRecord;

    if P^='{' then begin

      Typ := ptRecord;

      ExpectedEnd := eeCurly;

      repeat inc(P) until not(P^ in [#1..' ']);

    end else

    if P^='[' then begin

      Typ := ptArray;

      ExpectedEnd := eeSquare;

      repeat inc(P) until not(P^ in [#1..' ']);

    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 := length(TypIdent);

          if (len>12) and (TypIdent[1]='T') and

             IdemPropNameUSameLen(DYNARRAYTEXT,@PByteArray(TypIdent)[len-8],8) then begin

            ArrayTyp := TJSONCustomParserRTTI.TypeNameToSimpleRTTIType(

              @PByteArray(TypIdent)[1],len-9,ArrayTypIdent);

            if ArrayTyp=ptCustom then

              raise ESynException.CreatEUTF8('%.Parse: unknown %',[self,TypIdent]);

            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,TypeInfoToName(aRecordTypeInfo)]);

    {$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);

    SetRawUTF8(ItemFieldName,PAnsiChar(@ItemFields[i]^.NameLen)+1,ItemFields[i]^.NameLen);

    Item := AddItemFromRTTI(ItemFieldName,ItemField,ItemFieldSize);

    Props.fNestedProperty[i] := Item;

    case Item.PropertyType of

    ptArray: begin

      inc(PByte(ItemField),ItemField^.NameLen);

      ItemArray := AddItemFromRTTI('',Deref(ItemField^.elType2),

        ItemField^.elSize {$ifdef FPC}and $7FFFFFFF{$endif});

      if (ItemArray.PropertyType=ptCustom) and

         (ItemArray.ClassType=TJSONCustomParserRTTI) then

        FromEnhancedRTTI(Item,Deref(ItemField^.elType2)) else begin

        SetLength(Item.fNestedProperty,1);

        Item.fNestedProperty[0] := ItemArray;

        Item.ComputeNestedDataSize;

      end;

    end;

    ptCustom:

      if (ItemField<>nil) and (Item.ClassType=TJSONCustomParserRTTI) then

        FromEnhancedRTTI(Item,ItemField);

    end;

  end;

  Props.ComputeNestedDataSize;

end;



{$endif ISDELPHI2010}





{ ************ variant-based process, including JSON/BSON document content }



function SetVariantUnRefSimpleValue(const Source: variant; var Dest: TVarData): boolean;

var typ: word;

begin

  if TVarData(Source).VType and varByRef<>0 then begin

    typ := TVarData(Source).VType and not varByRef;

    case typ of

    varVariant:

      if PVarData(TVarData(Source).VPointer)^.VType in

          [varEmpty..varDate,varBoolean,varShortInt..varWord64] then begin

        Dest := PVarData(TVarData(Source).VPointer)^;

        result := true;

      end else

        result := false;

    varEmpty..varDate,varBoolean,varShortInt..varWord64: begin

      Dest.VType := typ;

      Dest.VInt64 :=  PInt64(TVarData(Source).VAny)^;

      result := true;

    end;

    else

      result := false;

    end;

  end else

    result := false;

end;



{$ifndef LVCL}



procedure RawByteStringToVariant(Data: PByte; DataLen: Integer; var Value: variant);

begin

  with TVarData(Value) do begin

    if VType and VTYPE_STATIC<>0 then

      VarClear(Value);

    if (Data=nil) or (DataLen<=0) then

      VType := varNull else begin

      VType := varString;

      VAny := nil; // avoid GPF below when assigning a string variable to VAny

      SetString(RawByteString(VAny),PAnsiChar(Data),DataLen);

    end;

  end;

end;



procedure RawByteStringToVariant(const Data: RawByteString; var Value: variant);

begin

  with TVarData(Value) do begin

    if VType and VTYPE_STATIC<>0 then

      VarClear(Value);

    if Data='' then

      VType := varNull else begin

      VType := varString;

      VAny := nil; // avoid GPF below when assigning a string variable to VAny

      RawByteString(VAny) := Data;

    end;

  end;

end;



procedure VariantToRawByteString(const Value: variant; var Dest: RawByteString);

begin

  case TVarData(Value).VType of

  varEmpty, varNull:

    Dest := '';

  varString:

    Dest := RawByteString(TVarData(Value).VAny);

  else // not from RawByteStringToVariant() -> conversion to string

    Dest := {$ifdef UNICODE}RawByteString{$else}string{$endif}(Value);

  end;

end;



procedure SetVariantNull(var Value: variant);

begin // slightly faster than Value := Null

  VarClear(Value);

  TVarData(Value).VType := varNull;

end;



{$endif LVCL}



function VarIsEmptyOrNull(const V: Variant): Boolean;

begin

  result := VarDataIsEmptyOrNull(@V);

end;



function VarDataIsEmptyOrNull(VarData: pointer): Boolean;

begin

  repeat

    if PVarData(VarData)^.VType<>varVariant or varByRef then

      break;

    VarData := PVarData(VarData)^.VPointer;

    if VarData=nil then begin

      result := true;

      exit;

    end;

  until false;

  result := (PVarData(VarData)^.VType<=varNull) or

            (PVarData(VarData)^.VType=varNull or varByRef);

end;



function VarIs(const V: Variant; const VTypes: TVarDataTypes): Boolean;

var VD: PVarData;

begin

  VD := @V;

  repeat

    if VD^.VType<>varVariant or varByRef then

      break;

    VD := VD^.VPointer;

    if VD=nil then begin

      result := false;

      exit;

    end;

  until false;

  result := VD^.VType in VTypes;

end;



function VarIsVoid(const V: Variant): boolean;

begin

  with TVarData(V) do

    case VType of

    varEmpty,varNull:

      result := true;

    varBoolean:

      result := not VBoolean;

    varString,varOleStr{$ifdef HASVARUSTRING},varUString{$endif}:

      result := VAny=nil;

    varDate:

      result := VInt64=0;

    else

      if VType=varVariant or varByRef then

        result := VarIsVoid(PVariant(VPointer)^) else

      if (VType=varByRef or varString) or (VType=varByRef or varOleStr)

         {$ifdef HASVARUSTRING} or (VType=varByRef or varUString) {$endif} then

        result := PPointer(VAny)^=nil else

      {$ifndef NOVARIANTS}

      if VType=word(DocVariantVType) then

        result := TDocVariantData(V).Count=0 else

      {$endif}

        result := false;

    end;

end;





{$ifndef NOVARIANTS}



/// internal method used by VariantLoadJSON(), GetVariantFromJSON() and

// TDocVariantData.InitJSONInPlace()

procedure GetJSONToAnyVariant(var Value: variant; var JSON: PUTF8Char;

  EndOfObject: PUTF8Char; Options: PDocVariantOptions); forward;



procedure SetVariantByRef(const Source: Variant; var Dest: Variant);

begin

  if TVarData(Dest).VType and VTYPE_STATIC<>0 then

    VarClear(Dest);

  if (TVarData(Source).VType=varVariant or varByRef) or

     (TVarData(Source).VType in // already byref or simple

       [varEmpty..varDate,varBoolean,varShortInt..varWord64]) then

    TVarData(Dest) := TVarData(Source) else

  if not SetVariantUnRefSimpleValue(Source,TVarData(Dest)) then begin

    TVarData(Dest).VType := varVariant or varByRef;

    TVarData(Dest).VPointer := @Source;

  end;

end;



procedure SetVariantByValue(const Source: Variant; var Dest: Variant);

var s: TVarData absolute Source;

    d: TVarData absolute Dest;

begin

  if d.VType and VTYPE_STATIC<>0 then

    VarClear(Dest);

  case s.VType of

  varEmpty..varDate,varBoolean,varShortInt..varWord64: begin

    d.VType := s.VType;

    d.VInt64 := s.VInt64;

  end;

  varString: begin

    d.VType := varString;

    d.VAny := nil;

    RawByteString(d.VAny) := RawByteString(s.VAny);

  end;

  varVariant or varByRef:

    Dest := PVariant(s.VPointer)^;

  varByRef or varString: begin

    d.VType := varString;

    d.VAny := nil;

    RawByteString(d.VAny) := PRawByteString(s.VAny)^;

  end;

  {$ifdef HASVARUSTRING} varUString, varByRef or varUString, {$endif}

  varOleStr, varByRef or varOleStr: begin

    d.VType := varString;

    d.VAny := nil;

    VariantToUTF8(Source,RawUTF8(d.VAny)); // store a RawUTF8 instance

  end;

  else

    if not SetVariantUnRefSimpleValue(Source,d) then

      Dest := Source;

  end;

end;



procedure ZeroFill(Value: PVarData);

begin // slightly faster than FillChar(Value,sizeof(Value),0);

  PInt64Array(Value)^[0] := 0;

  PInt64Array(Value)^[1] := 0;

  {$ifdef CPU64}

  //assert(SizeOf(TVarData)=24);

  PInt64Array(Value)^[2] := 0;

  {$endif}

end;



procedure RawUTF8ToVariant(Txt: PUTF8Char; TxtLen: integer; var Value: variant);

begin

  with TVarData(Value) do begin

    if VType<>varString then begin // in-place replacement of a RawUTF8 value

      if VType and VTYPE_STATIC<>0 then

        VarClear(Value);

      VType := varString;

      VAny := nil; // avoid GPF below when assigning a string variable to VAny

    end;

    SetRawUTF8(RawUTF8(VAny),Txt,TxtLen);

  end;

end;



procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: variant);

begin

  with TVarData(Value) do begin

    if VType<>varString then begin // in-place replacement of a RawUTF8 value

      if VType and VTYPE_STATIC<>0 then

        VarClear(Value);

      VType := varString;

      VAny := nil; // avoid GPF below when assigning a string variable to VAny

      if Txt='' then

        exit;

    end;

    RawByteString(VAny) := Txt;

    {$ifdef HASCODEPAGE}

    if (Txt<>'') and  (StringCodePage(Txt)=CP_RAWBYTESTRING) then

      SetCodePage(RawByteString(VAny),CP_UTF8,false); // force explicit UTF-8

    {$endif}

  end;

end;



function RawUTF8ToVariant(const Txt: RawUTF8): variant;

begin

  RawUTF8ToVariant(Txt,result);

end;



procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: TVarData;

  ExpectedValueType: word);

begin

  if Value.VType and VTYPE_STATIC<>0 then

    VarClear(variant(Value));

  Value.VType := ExpectedValueType;

  Value.VAny := nil; // avoid GPF below

  if Txt<>'' then

  case ExpectedValueType of

    varString: begin

      RawByteString(Value.VAny) := Txt;

      {$ifdef HASCODEPAGE}

      if (Txt<>'') and  (StringCodePage(Txt)=CP_RAWBYTESTRING) then

        SetCodePage(RawByteString(Value.VAny),CP_UTF8,false); // force explicit UTF-8

      {$endif}

    end;

    varOleStr:

      UTF8ToWideString(Txt,WideString(Value.VAny));

    {$ifdef HASVARUSTRING}

    varUString:

      UTF8DecodeToUnicodeString(pointer(Txt),length(Txt),UnicodeString(Value.VAny));

    {$endif}

    else raise ESynException.CreateUTF8('RawUTF8ToVariant(ExpectedValueType=%)',

      [ExpectedValueType]);

  end;

end;



function VariantSave(const Value: variant; Dest: PAnsiChar): PAnsiChar;

  procedure ComplexType;

  begin

    try

      Dest := pointer(ToVarString(VariantSaveJSON(Value),PByte(Dest)));

    except

      on Exception do

        Dest := nil; // notify invalid/unhandled variant content

    end;

  end;

var LenBytes: integer;

    tmp: TVarData;

begin

  with TVarData(Value) do

    if VType and varByRef<>0 then

      if VType=varVariant or varByRef then begin

        result := VariantSave(PVariant(VPointer)^,Dest);

        exit;

      end else

      if SetVariantUnRefSimpleValue(Value,tmp) then begin

        result := VariantSave(variant(tmp),Dest-sizeof(VType));

        exit;

      end;

  with TVarData(Value) do begin

    PWord(Dest)^ := VType;

    inc(Dest,sizeof(VType));

    case VType of

    varShortInt, varByte: begin

      Dest^ := AnsiChar(VByte);

      inc(Dest);

    end;

    varSmallint, varWord, varBoolean: begin

      PWord(Dest)^ := VWord;

      inc(Dest,sizeof(VWord));

    end;

    varSingle, varLongWord, varInteger: begin

      PInteger(Dest)^ := VInteger;

      inc(Dest,sizeof(VInteger));

    end;

    varInt64, varWord64, varDouble, varDate, varCurrency:begin

      PInt64(Dest)^ := VInt64;

      inc(Dest,sizeof(VInt64));

    end;

    varString, varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: begin

      if PtrUInt(VAny)=0 then

        LenBytes := 0 else begin

        LenBytes := PStrRec(Pointer(PtrUInt(VAny)-STRRECSIZE))^.length;

        {$ifdef HASVARUSTRING}

        if VType=varUString then

          LenBytes := LenBytes*2; // stored length is in bytes, not (wide)chars

        {$endif}

      end;

      Dest := pointer(ToVarUInt32(LenBytes,pointer(Dest)));

      if LenBytes>0 then begin

        MoveFast(PPtrUInt(VAny)^,Dest^,LenBytes); // direct raw copy

        inc(Dest,LenBytes);

      end;

    end;

    else ComplexType; // complex types are stored as JSON

    end;

  end;

  result := Dest;

end;



function VariantSaveLength(const Value: variant): integer;

var tmp: TVarData;

begin // match VariantSave() storage 

  with TVarData(Value) do

    if VType and varByRef<>0 then

      if VType=varVariant or varByRef then begin

        result := VariantSaveLength(PVariant(VPointer)^);

        exit;

      end else

      if SetVariantUnRefSimpleValue(Value,tmp) then begin

        result := VariantSaveLength(variant(tmp));

        exit;

      end;

  with TVarData(Value) do

  case VType of

  varShortInt, varByte:

    result := sizeof(VByte)+sizeof(VType);

  varSmallint, varWord, varBoolean:

    result := sizeof(VSmallint)+sizeof(VType);

  varSingle, varLongWord, varInteger:

    result := sizeof(VInteger)+sizeof(VType);

  varInt64, varWord64, varDouble, varDate, varCurrency:

    result := sizeof(VInt64)+sizeof(VType);

  varString, varOleStr:

    if PtrUInt(VAny)=0 then

      result := 1+sizeof(VType) else

      result := ToVarUInt32LengthWithData(PStrRec(Pointer(PtrUInt(VAny)-STRRECSIZE))^.length)

        +sizeof(VType);

   {$ifdef HASVARUSTRING}

   varUString:

    if PtrUInt(VAny)=0 then // stored length is in bytes, not (wide)chars

      result := 1+sizeof(VType) else

      result := ToVarUInt32LengthWithData(PStrRec(Pointer(PtrUInt(VAny)-STRRECSIZE))^.length*2)

        +sizeof(VType);

    {$endif}

  else

    try // complex types will be stored as JSON

      result := ToVarUInt32LengthWithData(VariantSaveJSONLength(Value))+sizeof(VType);

    except

      on Exception do

        result := 0; // notify invalid/unhandled variant content

    end;

  end;

end;



function VariantSave(const Value: variant): RawByteString;

var P: PAnsiChar;

begin

  SetString(result,nil,VariantSaveLength(Value));

  P := VariantSave(Value,pointer(result));

  if P-pointer(result)<>length(result) then

    raise ESynException.Create('VariantSave length');

end;



function VariantLoad(const Bin: RawByteString;

  CustomVariantOptions: PDocVariantOptions): variant;

begin

  if VariantLoad(result,Pointer(Bin),CustomVariantOptions)=nil then

    VarClear(result);

end;



function VariantLoad(var Value: variant; Source: PAnsiChar;

  CustomVariantOptions: PDocVariantOptions): PAnsiChar;

var JSON: PUTF8Char;

    tmp: TSynTempBuffer; // GetJSON*() does in-place unescape -> private copy

begin

  with TVarData(Value) do begin

    if VType and VTYPE_STATIC<>0 then

      VarClear(Value);

    VType := PWord(Source)^;

    inc(Source,SizeOf(VType));

    case VType of

    varShortInt, varByte: begin

      VByte := byte(Source^);

      inc(Source);

    end;

    varSmallint, varWord, varBoolean: begin

      VWord := PWord(Source)^;

      inc(Source,sizeof(VWord));

    end;

    varSingle, varLongWord, varInteger: begin

      VInteger := PInteger(Source)^;

      inc(Source,sizeof(VInteger));

    end;

    varInt64, varWord64, varDouble, varDate, varCurrency:begin

      VInt64 := PInt64(Source)^;

      inc(Source,sizeof(VInt64));

    end;

    varString, varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: begin

      VAny := nil; // avoid GPF below when assigning a string variable to VAny

      tmp.Len := FromVarUInt32(PByte(Source));

      case VType of

      varString:

        SetString(RawUTF8(VAny),Source,tmp.Len); // explicit RawUTF8

      varOleStr:

        SetString(WideString(VAny),PWideChar(Source),tmp.Len shr 1);

      {$ifdef HASVARUSTRING}

      varUString:

        SetString(UnicodeString(VAny),PWideChar(Source),tmp.Len shr 1);

      {$endif}

      end;

      inc(Source,tmp.Len);

    end;

    else

      if CustomVariantOptions<>nil then begin

        try // expected format for complex type is JSON (VType may differ)

          FromVarString(PByte(Source),tmp);

          try

            JSON := tmp.buf;

            VType := varEmpty; // avoid GPF below

            GetJSONToAnyVariant(Value,JSON,nil,CustomVariantOptions);

          finally

            tmp.Done;

          end;

        except

          on Exception do

            Source := nil; // notify invalid/unhandled variant content

        end;

      end else

        Source := nil; // notify unhandled type

    end;

  end;

  result := Source;

end;



procedure FromVarVariant(var Source: PByte; var Value: variant;

  CustomVariantOptions: PDocVariantOptions);

begin

  Source := PByte(VariantLoad(Value,PAnsiChar(Source),CustomVariantOptions));

end;



function VariantLoadJSON(var Value: variant; JSON: PUTF8Char;

  EndOfObject: PUTF8Char; TryCustomVariants: PDocVariantOptions): 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);

      end else

        GetJSONToAnyVariant(Value,result,EndOfObject,TryCustomVariants);

    end else

      GetJSONToAnyVariant(Value,result,EndOfObject,TryCustomVariants);

  end else begin

    Val := GetJSONField(result,result,@wasString,EndOfObject);

    GetVariantFromJSON(Val,wasString,Value);

  end;

  if result=nil then

    result := @NULCHAR;

end;



procedure VariantLoadJSON(var Value: Variant; const JSON: RawUTF8;

  TryCustomVariants: PDocVariantOptions);

var tmp: TSynTempBuffer;

begin

  tmp.Init(JSON);

  try

    VariantLoadJSON(Value,tmp.buf,nil,TryCustomVariants);

  finally

    tmp.Done;

  end;

end;



function VariantLoadJSON(const JSON: RawUTF8; TryCustomVariants: PDocVariantOptions): variant;

var tmp: TSynTempBuffer;

begin

  tmp.Init(JSON);

  try

    VariantLoadJSON(result,tmp.buf,nil,TryCustomVariants);

  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);

begin // not very optimized, but fast enough in practice, and creates valid JSON

  with DefaultTextWriterJSONClass.CreateOwnedStream do

  try

    AddVariant(Value,Escape);

    SetText(result);

  finally

    Free;

  end;

end;



function VariantSaveJSONLength(const Value: variant; Escape: TTextWriterKind): integer;

var Fake: TFakeWriterStream;

begin // will avoid most memory allocations, except for one 2KB internal buffer

  Fake := TFakeWriterStream.Create;

  try

    with DefaultTextWriterJSONClass.Create(Fake,2048) 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

  if TVarData(result).VType and VTYPE_STATIC=0 then

    TVarData(result).VType := varEmpty else

    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;

    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;

      VAny := nil; // avoid GPF on next line

      VarRecToUTF8(V,RawUTF8(VAny));

    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;



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;





{ TSynInvokeableVariantType }



procedure TSynInvokeableVariantType.Lookup(var Dest: TVarData; const V: TVarData;

  FullName: PUTF8Char);

var itemName: RawUTF8;

    Handler: TSynInvokeableVariantType;

    DestVar,LookupVar: TVarData;

begin

  Dest.VType := varEmpty; // left to Unassigned if not found

  DestVar := V;

  while DestVar.VType=varByRef or varVariant do

    DestVar := PVarData(DestVar.VPointer)^;

  repeat

    itemName := GetNextItem(FullName,'.');

    if itemName='' then

      exit;

    if DestVar.VType=DocVariantVType then begin

      if not TDocVariantData(DestVar).GetVarData(itemName,DestVar) then

        exit;

    end else

    if FindCustomVariantType(DestVar.VType,TCustomVariantType(Handler)) and

       Handler.InheritsFrom(TSynInvokeableVariantType) then

    try // handle any kind of document storage: TSynTableVariant,TBSONVariant...

      LookupVar.VType := varEmpty;

      Handler.IntGet(LookupVar,DestVar,pointer(itemName));

      if LookupVar.VType<=varNull then

        exit; // assume varNull means not found

      DestVar := LookupVar;

    except

      on Exception do begin

        DestVar.VType := varEmpty;

        exit;

      end;

    end else

      exit;

    while DestVar.VType=varByRef or varVariant do

      DestVar := PVarData(DestVar.VPointer)^;

    if (DestVar.VType=DocVariantVType) and

       (TDocVariantData(DestVar).VCount=0) then

      DestVar.VType := varNull; // recognize void TDocVariant as null

    if FullName=nil then begin // found full name scope

      Dest := DestVar;

      exit;

    end;

    // if we reached here, we should try for the next scope within Dest

    if DestVar.VType=VarType then // most likely to be of the same exact type

      continue;

    if FindCustomVariantType(DestVar.VType,TCustomVariantType(Handler)) and

       Handler.InheritsFrom(TSynInvokeableVariantType) then

      Handler.Lookup(Dest,DestVar,FullName);

    break;

  until false;

end;



function TSynInvokeableVariantType.IterateCount(const V: TVarData): integer;

begin

  result := -1; // this is not an array

end;



procedure TSynInvokeableVariantType.Iterate(var Dest: TVarData; const V: TVarData;

  Index: integer);

begin // do nothing

end;



{$ifndef FPC}

{$ifndef DELPHI6OROLDER}

function TSynInvokeableVariantType.FixupIdent(const AText: string): string;

begin

  result := AText; // NO uppercased identifier for our custom types!

end;

{$endif DELPHI6OROLDER}

{$endif FPC}



function TSynInvokeableVariantType.GetProperty(var Dest: TVarData;

  const V: TVarData; const Name: String): Boolean;

{$ifdef UNICODE}

var Buf: array[byte] of AnsiChar; // to avoid heap allocation

{$endif}

begin

{$ifdef UNICODE}

  RawUnicodeToUtf8(Buf,SizeOf(Buf),pointer(Name),length(Name));

  IntGet(Dest,V,Buf);

{$else}

  IntGet(Dest,V,pointer(Name));

{$endif}

  result := True;

end;



{$ifdef FPC_VARIANTSETVAR} // see http://mantis.freepascal.org/view.php?id=26773

function TSynInvokeableVariantType.SetProperty(var V: TVarData;

  const Name: string; const Value: TVarData): Boolean;

{$else}

function TSynInvokeableVariantType.SetProperty(const V: TVarData;

  const Name: string; const Value: TVarData): Boolean;

{$endif}

var ValueSet: TVarData;

    PropName: PAnsiChar;

{$ifdef UNICODE}

    Buf: array[byte] of AnsiChar; // to avoid heap allocation

{$endif}

begin

{$ifdef UNICODE}

  RawUnicodeToUtf8(Buf,SizeOf(Buf),pointer(Name),length(Name));

  PropName := @Buf[0];

{$else}

  PropName := pointer(Name);

{$endif}

  ValueSet.VString := nil; // to avoid GPF in RawUTF8(ValueSet.VString) below

  if Value.VType=varByRef or varOleStr then

    RawUnicodeToUtf8(PPointer(Value.VAny)^,length(PWideString(Value.VAny)^),

      RawUTF8(ValueSet.VString)) else

  if Value.VType=varOleStr then

    RawUnicodeToUtf8(Value.VAny,length(WideString(Value.VAny)),

      RawUTF8(ValueSet.VString)) else

  {$ifdef HASVARUSTRING}

  if Value.VType=varByRef or varUString then

    RawUnicodeToUtf8(PPointer(Value.VAny)^,length(PUnicodeString(Value.VAny)^),

      RawUTF8(ValueSet.VString)) else

  if Value.VType=varUString then

    RawUnicodeToUtf8(Value.VAny,length(UnicodeString(Value.VAny)),

      RawUTF8(ValueSet.VString)) else

  {$endif}

  if SetVariantUnRefSimpleValue(variant(Value),ValueSet) then begin

    IntSet(V,ValueSet,PropName);

    result := true;

    exit;

  end else begin

    IntSet(V,Value,PropName);

    result := true;

    exit;

  end;

  try // unpatched RTL does not like Unicode values :( -> transmit a RawUTF8

    ValueSet.VType := varString;

    IntSet(V,ValueSet,PropName);

  finally

    RawUTF8(ValueSet.VString) := ''; // avoid memory leak

  end;

  result := True;

end;



procedure TSynInvokeableVariantType.Clear(var V: TVarData);

begin

  ZeroFill(@V); // will set V.VType := varEmpty

end;



procedure TSynInvokeableVariantType.Copy(var Dest: TVarData;

  const Source: TVarData; const Indirect: Boolean);

begin

  if Indirect then

    SimplisticCopy(Dest,Source,true) else begin

    if Dest.VType and VTYPE_STATIC<>0 then

      VarClear(variant(Dest)); // Dest may be a complex type

    Dest := Source;

  end;

end;



procedure TSynInvokeableVariantType.CopyByValue(var Dest: TVarData; const Source: TVarData);

begin

  Copy(Dest,Source,false);

end;



function TSynInvokeableVariantType.TryJSONToVariant(var JSON: PUTF8Char;

  var Value: variant; EndOfObject: PUTF8Char): boolean;

begin

  result := false;

end;



procedure TSynInvokeableVariantType.ToJSON(W: TTextWriter; const Value: variant;

  Escape: TTextWriterKind);

begin

  raise ESynException.CreateUTF8('%.ToJSON: unimplemented variant type',[self]);

end;



function TSynInvokeableVariantType.IsOfType(const V: variant): boolean;

begin

  if self=nil then

    result := false else

    if TVarData(V).VType=varByRef or varVariant then

      result := IsOfType(PVariant(TVarData(V).VPointer)^) else

      result := TVarData(V).VType=VarType;

end;





{ TSynTableVariantType }



var

  SynTableVariantType: TCustomVariantType = nil;

  SynVariantTypes: TObjectList = nil;



function FindSynVariantType(aVarType: Word; out CustomType: TSynInvokeableVariantType): boolean;

var i: integer;

begin

  if SynVariantTypes<>nil then begin

    for i := 0 to SynVariantTypes.Count-1 do

      if TSynInvokeableVariantType(SynVariantTypes.List[i]).VarType=aVarType then begin

        CustomType := TSynInvokeableVariantType(SynVariantTypes.List[i]);

        result := true;

        exit;

      end;

  end;

  result := false;

end;



procedure GetJSONToAnyVariant(var Value: variant; var JSON: PUTF8Char;

  EndOfObject: PUTF8Char; Options: PDocVariantOptions);

// internal method used by VariantLoadJSON(), GetVariantFromJSON() and

// TDocVariantData.InitJSON()

var wasString: boolean;

  procedure ProcessSimple(Val: PUTF8Char);

  begin

    GetVariantFromJSON(Val,wasString,Value);

    if JSON=nil then

      JSON := @NULCHAR;

  end;

var i: integer;

    VariantType: ^TSynInvokeableVariantType;

    ToBeParsed: PUTF8Char;

    wasParsedWithinString: boolean;

begin

  if TVarData(Value).VType and VTYPE_STATIC<>0 then

    VarClear(Value);

  if EndOfObject<>nil then

    EndOfObject^ := ' ';

  if JSON^ in [#1..' '] then repeat inc(JSON) until not(JSON^ in [#1..' ']);

  if (Options=nil) or (JSON^ in ['1'..'9']) then begin // obvious simple type

    ProcessSimple(GetJSONField(JSON,JSON,@wasString,EndOfObject));

    exit;

  end;

  if JSON^='"' then

    if dvoJSONObjectParseWithinString in Options^ then begin

      ToBeParsed := GetJSONField(JSON,JSON,@wasString,EndOfObject);

      EndOfObject := nil; // already set just above

      wasParsedWithinString := true;

    end else begin

      ProcessSimple(GetJSONField(JSON,JSON,@wasString,EndOfObject));

      exit;

    end else begin

      ToBeParsed := JSON;

      wasParsedWithinString := false;

    end;

  if (SynVariantTypes<>nil) and

     not (dvoJSONParseDoNotTryCustomVariants in Options^) then begin

    VariantType := pointer(SynVariantTypes.List);

    for i := 1 to SynVariantTypes.Count do

      if VariantType^.TryJSONToVariant(ToBeParsed,Value,EndOfObject) then begin

        if not wasParsedWithinString then

          JSON := ToBeParsed;

        exit;

      end else

        inc(VariantType);

  end;

  if ToBeParsed^ in ['[','{'] then begin

    // default JSON parsing and conversion to TDocVariant instance

    ToBeParsed := TDocVariantData(Value).InitJSONInPlace(ToBeParsed,Options^,EndOfObject);

    if not wasParsedWithinString then

      JSON := ToBeParsed;

  end else

    // process to simple variant types

    if wasParsedWithinString then

      ProcessSimple(ToBeParsed) else

      ProcessSimple(GetJSONField(JSON,JSON,@wasString,EndOfObject));

end;



function TextToVariantNumberType(json: PUTF8Char): word;

var start: PUTF8Char;

label exponent;

begin

  start := json;

  if (json[0] in ['1'..'9']) or // is first char numeric?

     ((json[0]='0') and not (json[1] in ['0'..'9'])) or // '012' is invalid JSON

     ((json[0]='-') and (json[1] in ['0'..'9'])) then begin

    inc(json);

    repeat

      case json^ of

      '0'..'9':

        inc(json);

      '.':

        if (json[1] in ['0'..'9']) and (json[2] in [#0,'0'..'9']) then

          if (json[2]=#0) or (json[3]=#0) or

             ((json[3] in ['0'..'9']) and

              (json[4]=#0) or

              ((json[4] in ['0'..'9']) and (json[5]=#0))) then begin

            result := varCurrency; // currency ###.1234 number

            exit;

          end else begin

            repeat // more than 4 decimals

              inc(json)

            until not (json^ in ['0'..'9']);

            if json^ in ['e','E'] then begin

exponent:     inc(json);

              if json^ in ['+','-'] then

                inc(json);

              if not (json^ in ['0'..'9']) then

                break;

              repeat

                inc(json);

              until not (json^ in ['0'..'9']);

            end;

            if json^=#0 then begin

              result := varDouble; // (floating pointer number)

              exit;

            end;

            break;

          end else

          break;

      'e','E':

        goto exponent;

      #0:

        if json-start<=19 then begin // signed Int64 precision

          result := varInt64;

          exit;

        end else begin

          result := varDouble; // we may lost precision, but it is a number

          exit;

        end;

      else break;

      end;

    until false;

  end;

  result := varString;

end;



function GetNumericVariantFromJSON(JSON: PUTF8Char; var Value: TVarData): boolean;

var err: integer;

label dbl;

begin

  if JSON<>nil then

    with Value do

    case TextToVariantNumberType(JSON) of

    varInt64: begin

      VInt64 := GetInt64(JSON,err);

      if err<>0 then

        goto dbl; // overflow (>$7FFFFFFFFFFFFFFF) -> try floating point

      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;

  result := false;

end;



procedure GetVariantFromJSON(JSON: PUTF8Char; wasString: Boolean; var Value: variant;

  TryCustomVariants: PDocVariantOptions);

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) and (JSON^ in ['{','[']) then begin

    GetJSONToAnyVariant(Value,JSON,nil,TryCustomVariants);

    exit;

  end;

  // handle simple text or numerical values

  with TVarData(Value) do begin

    if VType and VTYPE_STATIC=0 then

      VType := varEmpty else

      VarClear(Value);

    if (JSON=nil) or ((PInteger(JSON)^=NULL_LOW) and not wasString) then begin

      VType := varNull;

      exit;

    end else

    if (PInteger(JSON)^=FALSE_LOW) and (JSON[4]='e') and

       (JSON[5] in EndOfJSONValueField) then begin

      VType := varBoolean;

      VBoolean := false;

      exit;

    end else

    if (PInteger(JSON)^=TRUE_LOW) and (JSON[4] in EndOfJSONValueField) then begin

      VType := varBoolean;

      VBoolean := true;

      exit;

    end else

    if not wasString then

      if GetNumericVariantFromJSON(JSON,TVarData(Value)) then

        exit;

    // found no numerical value -> return a string in the expected format

    VType := varString;

    VAny := nil; // avoid GPF below when assigning a string variable to VAny

    SetString(RawUTF8(VAny),PAnsiChar(JSON),StrLen(JSON));

  end;

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;



procedure TSynTableVariantType.IntGet(var Dest: TVarData;

  const V: TVarData; Name: PAnsiChar);

begin

  TSynTableData(V).GetFieldVariant(RawByteString(Name),variant(Dest));

end;



procedure TSynTableVariantType.IntSet(const V, Value: TVarData;

  Name: PAnsiChar);

begin

  TSynTableData(V).SetFieldValue(RawByteString(Name),Variant(Value));

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;



{$ifndef FPC} // better not try it with FPC - rely on the current implementation



function ParseParamPointer(P: pointer; aType: cardinal; var Value: TVarData): pointer;

var Size: Cardinal;

    ByRef: Boolean;

    V: Variant absolute Value;

const TYPE_BYREF = 128;

      TYPE_BYREF_MASK = TYPE_BYREF-1;

begin // this code should copy parameters without any reference count handling

  ZeroFill(@Value); // TVarData is expected to be bulk stack: no VarClear needed

  ByRef := (aType and TYPE_BYREF)<>0;

  Size := sizeof(pointer);

  case aType and TYPE_BYREF_MASK of

  varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord, varSingle: begin

    if ByRef then

      P := pointer(P^);

    Value.VType := aType and TYPE_BYREF_MASK;

    Value.VInteger := PInteger(P)^;

    {$ifdef CPU64}

    if not ByRef then

      Size := sizeof(Integer);

    {$endif}

  end;

  varDouble, varCurrency, varDate, varInt64, varWord64, varOleStr: begin

    if ByRef then

      P := pointer(P^);

    Value.VType := aType and TYPE_BYREF_MASK;

    Value.VInt64 := PInt64(P)^;

    {$ifndef CPU64}

    if not ByRef then

      Size := sizeof(Int64);

    {$endif}

  end;

  varStrArg: begin

    if ByRef then

      P := pointer(P^);

    Value.VType := varString;

    Value.VString := PPointer(P)^;

  end;

  {$ifdef HASVARUSTRARG}

  varUStrArg: begin

    if ByRef then

      P := pointer(P^);

    Value.VType := varUString;

    Value.VUString := PPointer(P)^;

  end;

  {$endif}

  varBoolean:

    if ByRef then

      V := PWordBool(pointer(P^))^ else

      V := PWordBool(P)^;

  varVariant:

    {$ifdef CPU64} // circumvent Delphi x64 compiler oddiness

    Value := PVarData(pointer(P^))^

    {$else}

    if ByRef then

      Value := PVarData(pointer(P^))^ else begin

      Value := PVarData(P)^;

      Size := Sizeof(Value);

    end;

    {$endif}

  else

    raise EInvalidCast.CreateFmt('ParseParamPointer: Invalid VarType=%d',

      [aType and TYPE_BYREF_MASK]);

  end;

  result := PAnsiChar(P)+Size;

end;



var

  LastDispInvokeType: TSynInvokeableVariantType;



procedure SynVarDispProc(Result: PVarData; const Instance: TVarData;

  CallDesc: PCallDesc; Params: Pointer); cdecl;

const DO_PROP = 1; GET_PROP = 2; SET_PROP = 4;

var Value: TVarData;

    Handler: TSynInvokeableVariantType;

    CacheDispInvokeType: TSynInvokeableVariantType; // to be thread-safe

begin

  if Instance.VType=varByRef or varVariant then // handle By Ref variants

    SynVarDispProc(Result,PVarData(Instance.VPointer)^,CallDesc,Params) else begin

    if Result<>nil then

      VarClear(Variant(Result^));

    case Instance.VType of

    varDispatch, varDispatch or varByRef,

    varUnknown, varUnknown or varByRef, varAny:

      // process Ole Automation variants

      if Assigned(VarDispProc) then

        VarDispProc(pointer(Result),Variant(Instance),CallDesc,@Params);

    else begin

      // first we check for our own TSynInvokeableVariantType types

      if SynVariantTypes<>nil then begin

        // simple cache for the latest type: most gets are grouped

        CacheDispInvokeType := LastDispInvokeType;

        if (CacheDispInvokeType<>nil) and

           (CacheDispInvokeType.VarType=TVarData(Instance).VType) and

           (CallDesc^.CallType in [GET_PROP, DO_PROP]) and

           (Result<>nil) and (CallDesc^.ArgCount=0) then begin

          CacheDispInvokeType.IntGet(Result^,Instance,@CallDesc^.ArgTypes[0]);

          exit;

        end;

      end;

      // handle any custom variant type

      if FindCustomVariantType(Instance.VType,TCustomVariantType(Handler)) then begin

        if Handler.InheritsFrom(TSynInvokeableVariantType) then

          case CallDesc^.CallType of

          GET_PROP, DO_PROP: // fast direct call of our IntGet() virtual method

            if (Result<>nil) and (CallDesc^.ArgCount=0) then begin

              Handler.IntGet(Result^,Instance,@CallDesc^.ArgTypes[0]);

              LastDispInvokeType := Handler; // speed up in loop

              exit;

            end;

          SET_PROP: // fast direct call of our IntSet() virtual method

            if (Result=nil) and (CallDesc^.ArgCount=1) then begin

              ParseParamPointer(@Params,CallDesc^.ArgTypes[0],Value);

              Handler.IntSet(Instance,Value,@CallDesc^.ArgTypes[1]);

              exit;

            end;

          end;

        // here we call the default code handling custom types

        Handler.DispInvoke({$ifdef DELPHI6OROLDER}Result^{$else}Result{$endif},

          Instance,CallDesc,@Params)

      end else

        raise EInvalidOp.CreateFmt('Invalid variant type %d invoke',[Instance.VType]);

    end;

    end;

  end;

end;



function VariantsDispInvokeAddress: pointer;

asm

  {$ifdef CPU64}

  mov rax,offset Variants.@DispInvoke

  {$else}

  mov eax,offset Variants.@DispInvoke

  {$endif}

end;



{$ifdef DOPATCHTRTL}

  {$define DOPATCHDISPINVOKE} // much faster late-binding process for our types

{$endif}

{$ifdef CPU64}

  {$define DOPATCHDISPINVOKE}

  // we NEED our patched DispInvoke to circumvent some Delphi bugs on Win64

{$endif}

{$ifdef DELPHI6OROLDER}

  {$define DOPATCHDISPINVOKE}

  // to circumvent LIdent := Uppercase() in TInvokeableVariantType.DispInvoke()

{$endif}



{$endif FPC}



function SynRegisterCustomVariantType(aClass: TSynInvokeableVariantTypeClass): TSynInvokeableVariantType;

var i: integer;

{$ifdef DOPATCHDISPINVOKE}

{$ifdef NOVARCOPYPROC}

    VarMgr: TVariantManager;

{$endif}

{$endif}

begin

  if SynVariantTypes=nil then begin

    {$ifndef FPC}

    {$ifdef DOPATCHDISPINVOKE}

    {$ifndef CPU64} // we NEED our patched RTL on Win64

    if DebugHook=0 then // patch VCL/RTL only outside debugging

    {$endif} begin

      {$ifdef NOVARCOPYPROC}

      GetVariantManager(VarMgr);

      VarMgr.DispInvoke := @SynVarDispProc;

      SetVariantManager(VarMgr);

      {$else}

      RedirectCode(VariantsDispInvokeAddress,@SynVarDispProc);

      {$endif NOVARCOPYPROC}

    end;

    {$endif DOPATCHDISPINVOKE}

    {$endif FPC}

    GarbageCollectorFreeAndNil(SynVariantTypes,TObjectList.Create);

  end else

    for i := 0 to SynVariantTypes.Count-1 do

    if PPointer(SynVariantTypes.List[i])^=pointer(aClass) then begin

      result := SynVariantTypes.List[i]; // returns already registered instance

      exit;

    end;

  result :=  aClass.Create; // register variant type

  SynVariantTypes.Add(result);

  if aClass=TDocVariant then

    DocVariantVType := result.VarType;

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;



function VariantTypeToSQLDBFieldType(const V: Variant): TSQLDBFieldType;

var tmp: TVarData;

begin

  with TVarData(V) do

  case VType of

  varEmpty:

    result := ftUnknown;

  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:

    if (VString<>nil) and (PCardinal(VString)^ and $ffffff=JSON_BASE64_MAGIC) then

      result := ftBlob else

      result := ftUTF8;

  else

  if SetVariantUnRefSimpleValue(V,tmp) then

    result := VariantTypeToSQLDBFieldType(variant(tmp)) else

    result := ftUTF8;

  end;

end;





{ TDocVariantData }



procedure TDocVariantData.Init(aOptions: TDocVariantOptions; aKind: TDocVariantKind);

begin

  if DocVariantType=nil then

    DocVariantType := SynRegisterCustomVariantType(TDocVariant);

  ZeroFill(@self);

  VType := DocVariantVType;

  VOptions := aOptions;

  VKind := aKind;

end;



procedure TDocVariantData.InitFast;

begin

  if DocVariantType=nil then

    DocVariantType := SynRegisterCustomVariantType(TDocVariant);

  ZeroFill(@self);

  VType := DocVariantVType;

  VOptions := JSON_OPTIONS_FAST;

end;



procedure TDocVariantData.InitFast(InitialCapacity: integer; aKind: TDocVariantKind);

begin

  Init(JSON_OPTIONS_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.AddNameValuesToObject(const NameValuePairs: array of const);

var n,arg: integer;

    tmp: variant;

begin

  n := length(NameValuePairs) shr 1;

  if (n=0) or (VKind=dvArray) then

    exit; // nothing to add

  VKind := dvObject;

  SetLength(VValue,VCount+n);

  SetLength(VName,VCount+n);

  for arg := 0 to n-1 do begin

    VarRecToUTF8(NameValuePairs[arg*2],VName[arg+VCount]);

    if dvoValueCopiedByReference in VOptions then

      VarRecToVariant(NameValuePairs[arg*2+1],VValue[arg+VCount]) else begin

      VarRecToVariant(NameValuePairs[arg*2+1],tmp);

      SetVariantByValue(tmp,VValue[arg+VCount]);

    end;

  end;

  inc(VCount,n);

end;



procedure TDocVariantData.AddOrUpdateNameValuesToObject(const NameValuePairs: array of const);

var n,arg: integer;

    n2: RawUTF8;

    v: Variant;

begin

  n := length(NameValuePairs) shr 1;

  if (n=0) or (VKind=dvArray) then

    exit; // nothing to add

  for arg := 0 to n-1 do begin

    VarRecToUTF8(NameValuePairs[arg*2],n2);

    VarRecToVariant(NameValuePairs[arg*2+1],v);

    AddOrUpdateValue(n2,v)

  end;

end;



procedure TDocVariantData.AddOrUpdateObject(const NewValues: variant;

  OnlyAddMissing: boolean);

var n: integer;

    new: PDocVariantData;

begin

  new := _Safe(NewValues);

  if (VKind<>dvArray) and (new^.VKind<>dvArray) then

    for n := 0 to new^.Count-1 do

      AddOrUpdateValue(new^.Names[n],new^.Values[n],nil,OnlyAddMissing);

end;



procedure TDocVariantData.InitArray(const Items: array of const;

  aOptions: TDocVariantOptions=[]);

var arg: integer;

    tmp: variant;

begin

  Init(aOptions,dvArray);

  if high(Items)>=0 then begin

    VCount := length(Items);

    SetLength(VValue,VCount);

    if dvoValueCopiedByReference in aOptions then

      for arg := 0 to high(Items) do

        VarRecToVariant(Items[arg],VValue[arg]) else

      for arg := 0 to high(Items) do begin

        VarRecToVariant(Items[arg],tmp);

        SetVariantByValue(tmp,VValue[arg]);

      end;

  end;

end;



procedure TDocVariantData.InitArrayFromVariants(const Items: TVariantDynArray;

  aOptions: TDocVariantOptions; ItemsCopiedByReference: boolean);

begin

  if Items=nil then

    VType := varNull else begin

    Init(aOptions,dvArray);

    VCount := length(Items);

    VValue := Items; // fast by-reference copy of VValue[]

    if not ItemsCopiedByReference then

      InitCopy(variant(self),aOptions);

  end;

end;



procedure TDocVariantData.InitArrayFromObjArray(const ObjArray;

  aOptions: TDocVariantOptions; aWriterOptions: TTextWriterWriteObjectOptions);

var ndx: integer;

    Items: TObjectDynArray absolute ObjArray;

begin

  if Items=nil then

    VType := varNull else begin

    Init(aOptions,dvArray);

    VCount := length(Items);

    SetLength(VValue,VCount);

    for ndx := 0 to VCount-1 do

      ObjectToVariant(Items[ndx],VValue[ndx],aWriterOptions);

  end;

end;



procedure TDocVariantData.InitArrayFrom(const Items: TRawUTF8DynArray; aOptions: TDocVariantOptions);

var ndx: integer;

begin

  if Items=nil then

    VType := varNull else begin

    Init(aOptions,dvArray);

    VCount := length(Items);

    SetLength(VValue,VCount);

    for ndx := 0 to VCount-1 do

      RawUTF8ToVariant(Items[ndx],VValue[ndx]);

  end;

end;



procedure TDocVariantData.InitArrayFrom(const Items: TIntegerDynArray; aOptions: TDocVariantOptions);

var ndx: integer;

begin

  if Items=nil then

    VType := varNull else begin

    Init(aOptions,dvArray);

    VCount := length(Items);

    SetLength(VValue,VCount);

    for ndx := 0 to VCount-1 do

      VValue[ndx] := Items[ndx];

  end;

end;



procedure TDocVariantData.InitArrayFrom(const Items: TInt64DynArray; aOptions: TDocVariantOptions);

var ndx: integer;

begin

  if Items=nil then

    VType := varNull else begin

    Init(aOptions,dvArray);

    VCount := length(Items);

    SetLength(VValue,VCount);

    for ndx := 0 to VCount-1 do

      VValue[ndx] := Items[ndx];

  end;

end;



procedure TDocVariantData.InitFromTypeInfo(const aValue; aTypeInfo: pointer;

  aEnumSetsAsText: boolean; aOptions: TDocVariantOptions);

var tmp: RawUTF8;

begin

  SaveJSON(aValue,aTypeInfo,aEnumSetsAsText, tmp);

  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;

    n: integer;

begin

  Init(aOptions);

  result := nil;

  if JSON=nil then

    exit;

  if JSON^ in [#1..' '] then repeat inc(JSON) until not(JSON^ in [#1..' ']);

  case JSON^ of

  '[': begin

    repeat inc(JSON) until not(JSON^ in [#1..' ']);

    n := JSONArrayCount(JSON); // may be slow if JSON is huge (not very common)

    if n<0 then

      exit; // invalid content

    VKind := dvArray;

    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);

        if JSON=nil then

          exit;

        inc(VCount);

      until EndOfObject=']';

    end else

      if JSON^=']' then // n=0

        repeat inc(JSON) until not(JSON^ in [#1..' ']) else

        exit;

  end;

  '{': begin

    repeat inc(JSON) until not(JSON^ in [#1..' ']);

    n := JSONObjectPropCount(JSON); // may be slow if JSON is huge (not very common)

    if n<0 then

      exit; // invalid content

    VKind := dvObject;

    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);

        if Name=nil then

          exit;

        SetString(VName[VCount],PAnsiChar(Name),StrLen(Name));

        GetJSONToAnyVariant(VValue[VCount],JSON,@EndOfObject,@VOptions);

        if JSON=nil then

          exit;

        inc(VCount);

      until EndOfObject='}';

    end else

      if JSON^='}' then // n=0

        repeat inc(JSON) until not(JSON^ in [#1..' ']) else

        exit;

  end;

  'n','N': begin

    if IdemPChar(JSON+1,'ULL') then begin

      VKind := dvObject;

      result := GotoNextNotSpace(JSON+4);

    end;

    exit;

  end;

  else exit;

  end;

  if JSON^ in [#1..' '] then repeat inc(JSON) until not(JSON^ in [#1..' ']);

  if aEndOfObject<>nil then

    aEndOfObject^ := JSON^;

  if JSON^<>#0 then

    repeat inc(JSON) until not(JSON^ in [#1..' ']);

  result := JSON; // indicates successfully parsed

end;



function TDocVariantData.InitJSON(const JSON: RawUTF8;

  aOptions: TDocVariantOptions): boolean;

var tmp: TSynTempBuffer;

begin

  if JSON='' then 

    result := false else begin

    tmp.Init(JSON);

    try

      result := InitJSONInPlace(tmp.buf,aOptions)<>nil;

    finally

      tmp.Done;

    end;

  end;

end;



function TDocVariantData.InitJSONFromFile(const JsonFile: TFileName;

  aOptions: TDocVariantOptions): boolean;

begin

  result := InitJSONInPlace(pointer(AnyTextFileToRawUTF8(JsonFile,true)),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

    n := GetNextItem(CSV,NameValueSep);

    v := GetNextItem(CSV,ItemSep);

    if DoTrim then

      v := trim(v);

    if n='' then

      break;

    RawUTF8ToVariant(v,val);

    AddValue(n,val);

  end;

end;



procedure TDocVariantData.InitCSV(const CSV: RawUTF8; aOptions: TDocVariantOptions;

  NameValueSep, ItemSep: AnsiChar; DoTrim: boolean);

begin

  InitCSV(pointer(CSV),aOptions,NameValueSep,ItemSep,DoTrim);

end;



procedure TDocVariantData.InitCopy(const SourceDocVariant: variant;

  aOptions: TDocVariantOptions);

var ndx: integer;

    Source: PDocVariantData;

    SourceVValue: TVariantDynArray;

    Handler: TCustomVariantType;

    t: word;

    v: PVarData;

begin

  with TVarData(SourceDocVariant) do

    if VType=varByRef or varVariant then

      Source := VPointer else

      Source := @SourceDocVariant;

  if (DocVariantType=nil) or (Source^.VType<>DocVariantVType) then

    raise ESynException.CreateUTF8('No TDocVariant for InitCopy(%)',[Source.VType]);

  SourceVValue := Source^.VValue; // local fast per-reference copy

  if Source<>@self then begin

    VType := DocVariantVType;

    VKind := Source^.Kind;

    VCount := Source^.VCount;

    pointer(VName) := nil;  // avoid GPF

    VName := Source^.VName;

    pointer(VValue) := nil;

  end else

    VariantDynArrayClear(VValue); // force re-create full copy of all values

  if VCount>0 then begin

    SetLength(VValue,VCount);

    for ndx := 0 to VCount-1 do begin

      v := @SourceVValue[ndx];

      while v^.VType=varByRef or varVariant do

        v := v^.VPointer;

      t := v^.VType;

      if t<=varNativeString then // simple string/number types copy

        VValue[ndx] := variant(v^) else

      if t=VType then // direct recursive copy for TDocVariant

        TDocVariantData(VValue[ndx]).InitCopy(variant(v^),aOptions) else

      if FindCustomVariantType(t,Handler) then

        if Handler.InheritsFrom(TSynInvokeableVariantType) then

          TSynInvokeableVariantType(Handler).CopyByValue(

            TVarData(VValue[ndx]),v^) else

          Handler.Copy(TVarData(VValue[ndx]),v^,false) else

        VValue[ndx] := variant(v^); // default copy

    end;

  end;

  VariantDynArrayClear(SourceVValue); // faster alternative

  VOptions := aOptions; // may not be the same as in Source

end;



procedure TDocVariantData.Clear;

begin

  if VType=DocVariantVType then

    DocVariantType.Clear(TVarData(self)) else

    VarClear(variant(self));

end;



procedure TDocVariantData.Reset;

var opt: TDocVariantOptions;

begin

  opt := VOptions;

  DocVariantType.Clear(TVarData(self));

  VType := DocVariantVType;

  VOptions := opt;

end;



procedure TDocVariantData.SetCount(aCount: integer);

begin

  VCount := aCount;

end;



function TDocVariantData.InternalAdd(const aName: RawUTF8): integer;

var len: integer;

begin

  if aName<>'' then

    case Kind of // aName is set for an object

      dvUndefined: begin

        VType := DocVariantVType; // may not be set yet

        VKind := dvObject;

      end;

      dvArray:

        raise EDocVariant.CreateUTF8('Unexpected "%" property name in an array',[aName]);

    end else

    case Kind of // aName is not set for an array

      dvUndefined: begin

        VType := DocVariantVType; // may not be set yet

        VKind := dvArray;

      end;

      dvObject:

        raise EDocVariant.Create('Unexpected array item added to an object');

    end;

  if VValue=nil then

    SetLength(VValue,16) else

  if VCount>=length(VValue) then

    SetLength(VValue,VCount+VCount shr 3+32);

  if VKind=dvObject then begin

    len := length(VValue);

    if Length(VName)<>len then

      SetLength(VName,len);

    VName[VCount] := aName;

  end;

  result := VCount;

  inc(VCount);

end;



procedure TDocVariantData.SetCapacity(aValue: integer);

begin

  if VKind=dvObject then

    SetLength(VName,aValue);

  SetLength(VValue,aValue);

end;



function TDocVariantData.GetCapacity: integer;

begin

  result := length(VValue);

end;



function TDocVariantData.AddValue(const aName: RawUTF8; const aValue: variant): integer;

var ndx: integer;

begin

  if dvoCheckForDuplicatedNames in VOptions then begin

    ndx := GetValueIndex(aName);

    if ndx>=0 then

      raise EDocVariant.CreateUTF8('Duplicated "%" name',[aName]);

  end;

  result := InternalAdd(aName); // FPC does not allow VValue[InternalAdd(aName)]

  SetVariantByValue(aValue,VValue[result]);

end;



function TDocVariantData.AddValue(aName: PUTF8Char; aNameLen: integer; const aValue: variant): integer;

var tmp: RawUTF8;

begin

  SetString(tmp,PAnsiChar(aName),aNameLen);

  result := AddValue(tmp,aValue);

end;



function TDocVariantData.AddValueFromText(const aName,aValue: RawUTF8; Update: boolean): integer;

begin

  if aName='' then begin

    result := -1;

    exit;

  end;

  result := GetValueIndex(aName);

  if (not Update) and (dvoCheckForDuplicatedNames in VOptions) and (result>=0) then

    raise EDocVariant.CreateUTF8('Duplicated "%" name',[aName]);

  if result<0 then

    result := InternalAdd(aName);

  VarClear(VValue[result]);

  if not GetNumericVariantFromJSON(pointer(aValue),TVarData(VValue[result])) then

    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 (aSource.VKind<>dvObject) or (VKind=dvArray) then

    exit;

  for p := 0 to High(aPaths) do begin

    DocVariantType.Lookup(v,TVarData(aSource),pointer(aPaths[p]));

    if v.VType<varNull then

      continue; // path not found

    added := InternalAdd(aPaths[p]);

    PVarData(@VValue[added])^ := v;

  end;

end;



procedure TDocVariantData.AddFrom(const aDocVariant: Variant);

var source: PDocVariantData;

    ndx: integer;

begin

  source := _Safe(aDocVariant);

  if source^.Count=0 then

    exit; // nothing to add

  if (VKind<>dvUndefined) and (VKind<>source^.VKind) then

    exit; // types should match

  if source^.VKind=dvArray then

    for ndx := 0 to source^.Count-1 do

      AddItem(source^.VValue[ndx]) else

    for ndx := 0 to source^.Count-1 do

      AddValue(source^.VName[ndx],source^.VValue[ndx]);

end;



function TDocVariantData.AddItem(const aValue: variant): integer;

begin

  result := InternalAdd(''); // FPC does not allow VValue[InternalAdd(aName)]

  SetVariantByValue(aValue,VValue[result]);

end;



procedure TDocVariantData.AddItems(const aValue: array of const);

var ndx,added: integer;

begin

  for ndx := 0 to high(aValue) do begin

    added := InternalAdd(''); // FPC does not allow VValue[InternalAdd(aName)]

    VarRecToVariant(aValue[ndx],VValue[added]);

  end;

end;



function TDocVariantData.SearchItemByProp(const aPropName,aPropValue: RawUTF8;

  aCaseSensitive: boolean): integer;

var ndx: integer;

    tmp: RawUTF8;

    wasString: boolean;

    v: PVarData;

begin

  if VKind=dvArray then

    for result := 0 to VCount-1 do

      with _Safe(VValue[result])^ do

        if VKind=dvObject then begin

          ndx := GetValueIndex(aPropName);

          if ndx>=0 then begin

            v := @VValue[ndx];

            case v^.VType of

            varEmpty,varNull:

              if aPropValue='' then

                exit; // VariantToUTF8(null)='null'

            varString:

              if aCaseSensitive then begin

                if RawUTF8(v^.VAny)=aPropValue then

                  exit;

              end else

                if IdemPropNameU(RawUTF8(v^.VAny),aPropValue) then

                  exit;

            else begin

              VariantToUTF8(PVariant(v)^,tmp,wasString);

              if aCaseSensitive then begin

                if tmp=aPropValue then

                  exit;

              end else

                if IdemPropNameU(tmp,aPropValue) then

                  exit;

            end;

            end;

          end;

        end;

  result := -1;

end;



function TDocVariantData.SearchItemByValue(const aValue: Variant;

  CaseInsensitive: boolean; StartIndex: integer): integer;

begin

  for result := StartIndex to VCount-1 do

  if SortDynArrayVariantComp(TVarData(VValue[result]),TVarData(aValue),CaseInsensitive)=0 then

      exit;

  result := -1;

end;



procedure QuickSortDocVariant(names: PPointerArray; values: PVariantArray;

  L, R: PtrInt; Compare: TUTF8Compare);

var I, J, P: PtrInt;

    pivot, Tmp: pointer;

begin

  if L<R then

  repeat

    I := L; J := R;

    P := (L + R) shr 1;

    repeat

      pivot := names[P];

      while Compare(names[I],pivot)<0 do Inc(I);

      while Compare(names[J],pivot)>0 do Dec(J);

      if I <= J then begin

        Tmp := names[J]; names[J] := names[I]; names[I] := Tmp;

        {$ifdef CPU64}

        Exchg(@values[I],@values[J],sizeof(TVarData));

        {$else}

        Exchg16(@values[I],@values[J]);

        {$endif}

        if P = I then P := J else if P = J then P := I;

        inc(I); dec(J);

      end;

    until I > J;

    if L < J then

      QuickSortDocVariant(names,values,L,J,Compare);

    L := I;

  until I >= R;

end;



procedure TDocVariantData.SortByName(Compare: TUTF8Compare=nil);

begin

  if (VKind<>dvObject) or (VCount=0) then

    exit;

  if not Assigned(Compare) then

    Compare := @StrIComp;

  QuickSortDocVariant(pointer(VName),pointer(VValue),0,VCount-1,Compare);

end;



procedure TDocVariantData.ExchgValues(v1,v2: integer);

var n: pointer;

    v: TVarData;

begin

  if VName<>nil then begin // VName=[] for dvArray

    n := pointer(VName[v2]);

    pointer(VName[v2]) := pointer(VName[v1]);

    PPointerArray(VName)[v1] := n;

  end;

  v := TVarData(VValue[v2]);

  TVarData(VValue[v2]) := TVarData(VValue[v1]);

  TVarData(VValue[v1]) := v;

end;



procedure QuickSortDocVariantValues(var Doc: TDocVariantData;

  L, R: PtrInt; Compare: TVariantCompare);

var I, J, P: PtrInt;

    pivot: PVariant;

begin

  if L<R then

  repeat

    I := L; J := R;

    P := (L + R) shr 1;

    repeat

      pivot := @Doc.VValue[P];

      while Compare(Doc.VValue[I],pivot^)<0 do Inc(I);

      while Compare(Doc.VValue[J],pivot^)>0 do Dec(J);

      if I <= J then begin

        Doc.ExchgValues(I,J);

        if P = I then P := J else if P = J then P := I;

        inc(I); dec(J);

      end;

    until I > J;

    if L < J then

      QuickSortDocVariantValues(Doc,L,J,Compare);

    L := I;

  until I >= R;

end;



procedure TDocVariantData.SortByValue(Compare: TVariantCompare);

begin

  if VCount>0 then

    QuickSortDocVariantValues(self,0,VCount-1,Compare);

end;



procedure TDocVariantData.Reverse;

var arr: TDynArray;

begin

  if (VKind=dvUndefined) or (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;

  case VKind of

  dvObject:

    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;

  dvArray:

    for ndx := 0 to VCount-1 do begin

      _Safe(VValue[ndx])^.Reduce(aPropNames,aCaseSensitive,reduced,aDoNotAddVoidProp);

      if reduced.VKind=dvObject then

        result.AddItem(variant(reduced));

    end;

  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 (VKind<>dvArray) 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 (VKind<>dvArray) 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.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 (VKind<>dvObject) then

    exit;

  PWord(UpperCopy255(Up,aObjectPropName))^ := ord('.'); // e.g. 'P.'

  for ndx := 0 to Count-1 do

    if not IdemPChar(pointer(VName[ndx]),Up) then

      exit; // all fields should match "p.####"

  len := length(aObjectPropName)+1;

  for ndx := 0 to Count-1 do

    system.delete(VName[ndx],1,len);

  nested := self;

  Clear;

  InitObject([aObjectPropName,variant(nested)]);

  result := true;

end;



function TDocVariantData.Delete(Index: integer): boolean;

begin

  if cardinal(Index)>=cardinal(VCount) then

    result := false else begin

    dec(VCount);

    if VName<>nil then

      VName[Index] := '';

    VarClear(VValue[Index]);

    if Index<VCount then begin

      if VName<>nil 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;

  aCaseSensitive: boolean): boolean;

begin

  result := Delete(SearchItemByProp(aPropName,aPropValue,aCaseSensitive));

end;



function TDocVariantData.DeleteByValue(const aValue: Variant;

  CaseInsensitive: boolean=false): boolean;

var ndx: integer;

begin

  result := false;

  for ndx := VCount-1 downto 0 do

  if SortDynArrayVariantComp(TVarData(VValue[ndx]),TVarData(aValue),CaseInsensitive)=0 then begin

    Delete(ndx);

    result := true;

  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 (VKind<>dvObject) or (aStartNameLen=0) then

    exit;

  UpperCopy255Buf(upname,aStartName,aStartNameLen)^ := #0;

  for ndx := Count-1 downto 0 do

    if IdemPChar(pointer(Names[ndx]),upname) then begin

      Delete(ndx);

      inc(result);

    end;

end;



function TDocVariantData.GetValueIndex(aName: PUTF8Char; aNameLen: integer;

  aCaseSensitive: boolean): integer;

var err: integer;

begin

  if Kind=dvArray then begin

    result := GetInteger(aName,err);

    if err<>0 then

      raise EDocVariant.CreateUTF8('Impossible to find "%" property in an array',[aName]);

    if cardinal(result)>=cardinal(VCount) then

      raise EDocVariant.CreateUTF8('Out of range [%] property in an array',[aName]);

    exit;

  end;

  // simple lookup for object names -> hashing may be needed for huge count

  if aCaseSensitive then begin

    for result := 0 to VCount-1 do

      if (length(VName[result])=aNameLen) and

         CompareMem(pointer(VName[result]),aName,aNameLen) then

        exit;

  end else

    for result := 0 to VCount-1 do

      if (length(VName[result])=aNameLen) and

         IdemPropNameUSameLen(pointer(VName[result]),aName,aNameLen) then

        exit;

  result := -1;

end;



function TDocVariantData.GetValueIndex(const aName: RawUTF8): integer;

begin

  result := GetValueIndex(Pointer(aName),Length(aName),dvoNameCaseSensitive in VOptions);

end;



function TDocVariantData.GetValueOrRaiseException(const aName: RawUTF8): variant;

begin

  RetrieveValueOrRaiseException(pointer(aName),length(aName),

    dvoNameCaseSensitive in VOptions,result,false);

end;



function TDocVariantData.GetValueOrDefault(const aName: RawUTF8;

  const aDefault: variant): variant;

var ndx: integer;

begin

  if (DocVariantType=nil) or (VType<>DocVariantVType) or

     (Kind<>dvObject) 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 (DocVariantType=nil) or (VType<>DocVariantVType) or

     (Kind<>dvObject) 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 (DocVariantType<>nil) and (VType=DocVariantVType) and

     (Kind=dvObject) 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

    VariantToUTF8(PVariant(found)^,aValue,wasString);

    result := true;

  end;

end;



function TDocVariantData.GetAsDocVariant(const aName: RawUTF8; out aValue: PDocVariantData;

  aSortedCompare: TUTF8Compare=nil): boolean;

var found: PVarData;

begin

  found := GetVarData(aName,aSortedCompare);

  if found=nil then

    result := false else begin

    aValue := _Safe(PVariant(found)^);

    result := aValue<>@DocVariantDataFake;

  end;

end;



function TDocVariantData.GetAsDocVariantSafe(const aName: RawUTF8;

  aSortedCompare: TUTF8Compare): PDocVariantData;

var found: PVarData;

begin

  found := GetVarData(aName,aSortedCompare);

  if found=nil then

    result := @DocVariantDataFake else

    result := _Safe(PVariant(found)^);

end;



function TDocVariantData.GetAsPVariant(const aName: RawUTF8; out aValue: PVariant;

  aSortedCompare: TUTF8Compare=nil): boolean;

begin

  aValue := pointer(GetVarData(aName,aSortedCompare));

  result := aValue<>nil;

end;



function TDocVariantData.GetVarData(const aName: RawUTF8;

  var aValue: TVarData; aSortedCompare: TUTF8Compare): boolean;

var found: PVarData;

begin

  found := GetVarData(aName,aSortedCompare);

  if found=nil then

    result := false else begin

    aValue := found^;

    result := true;

  end;

end;



function TDocVariantData.GetVarData(const aName: RawUTF8;

  aSortedCompare: TUTF8Compare): PVarData;

var ndx: Integer;

begin

  if (DocVariantType=nil) or (VType<>DocVariantVType) or

     (Kind<>dvObject) or (VCount=0) then

    result := nil else begin

    if Assigned(aSortedCompare) then

      ndx := FastFindPUTF8CharSorted(pointer(VName),VCount-1,pointer(aName),aSortedCompare) else

      ndx := FindRawUTF8(VName,VCount,aName,not(dvoNameCaseSensitive in VOptions));

    if ndx>=0 then

      result := @VValue[ndx] else

      result := nil;

  end;

end;



function TDocVariantData.GetValueByPath(const aPath: RawUTF8): variant;

var Dest: TVarData;

begin

  VarClear(result);

  if (DocVariantType=nil) or (VType<>DocVariantVType) or

     (Kind<>dvObject) then

    exit;

  DocVariantType.Lookup(Dest,TVarData(self),pointer(aPath));

  if Dest.VType>=varNull then

    result := variant(Dest); // copy

end;



function TDocVariantData.GetValueByPath(const aPath: RawUTF8; out aValue: variant): boolean;

var Dest: TVarData;

begin

  result := false;

  if (DocVariantType=nil) or (VType<>DocVariantVType) or

     (Kind<>dvObject) 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;

  addIfNotExisting: boolean=false): PVariant;

var p{,ppar}: integer;

    path: TRawUTF8DynArray;

    par: PVariant;

begin

  result := nil;

  if (DocVariantType=nil) or (VType<>DocVariantVType) or (aPath='') then

    exit;

  CSVToRawUTF8DynArray(pointer(aPath),path,'.');

  par := @self;

//  ppar := -1;

  if (Kind=dvObject) and (Count>0) then

    for p := 0 to length(path)-1 do begin

      if _Safe(par^).GetAsPVariant(path[p],result) then

        par := result else begin

        result := nil;

        //ppar := p;

        break;

      end;

    end;

  if par=result then // found

    exit;

  if not addIfNotExisting then begin

    result := nil;

    exit;

  end;

  { TODO: add if not existing }

  result := nil;

end;



function TDocVariantData.GetValueByPath(const aDocVariantPath: array of RawUTF8): variant;

var found,res: PVarData;

    P: integer;

begin

  VarClear(result);

  if (DocVariantType=nil) or (VType<>DocVariantVType) or

     (Kind<>dvObject) or (high(aDocVariantPath)<0) then

    exit;

  found := @self;

  P := 0;

  repeat

    found := PDocVariantData(found).GetVarData(aDocVariantPath[P]);

    if found=nil then

      exit;

    if P=high(aDocVariantPath) then

      break; // we found the item!

    inc(P);

    // if we reached here, we should try for the next scope within Dest

    while found^.VType=varByRef or varVariant do

      found := found^.VPointer;

    if found^.VType=VType then

      continue;

    exit;

  until false;

  res := found;

  while res^.VType=varByRef or varVariant do

    res := res^.VPointer;

  if (res^.VType=VType) and (PDocVariantData(res)^.VCount=0) then

    // return void TDocVariant as null

    TVarData(result).VType := varNull else

    // copy found value

    result := PVariant(found)^;

end;



function TDocVariantData.GetItemByProp(const aPropName,aPropValue: RawUTF8;

  aCaseSensitive: boolean; var Dest: variant; DestByRef: boolean): boolean;

var ndx: integer;

begin

  ndx := SearchItemByProp(aPropName,aPropValue,aCaseSensitive);

  if ndx<0 then

    result := false else begin

    RetrieveValueOrRaiseException(ndx,Dest,DestByRef);

    result := true;

  end;

end;



function TDocVariantData.GetDocVariantByProp(const aPropName,aPropValue: RawUTF8;

  aCaseSensitive: boolean; out Dest: PDocVariantData): boolean;

var ndx: integer;

begin

  ndx := SearchItemByProp(aPropName,aPropValue,aCaseSensitive);

  if ndx<0 then

    result := false else begin

    Dest := DocVariantData(VValue[ndx]);

    result := true;

  end;

end;



function TDocVariantData.GetJsonByStartName(const aStartName: RawUTF8): RawUTF8;

var Up: array[byte] of AnsiChar;

    ndx: integer;

    W: TTextWriter;

begin

  if (Kind<>dvObject) or (VCount=0) then begin

    result := 'null';

    exit;

  end;

  UpperCopy255(Up,aStartName)^ := #0;

  W := DefaultTextWriterJSONClass.CreateOwnedStream;

  try

    W.Add('{');

    for ndx := 0 to VCount-1 do

    if IdemPChar(Pointer(VName[ndx]),Up) then begin

      if (dvoSerializeAsExtendedJson in VOptions) and

         JsonPropNameValid(pointer(VName[ndx])) then begin

        W.AddNoJSONEscape(pointer(VName[ndx]),Length(VName[ndx]));

      end else begin

        W.Add('"');

        W.AddJSONEscape(pointer(VName[ndx]),Length(VName[ndx]));

        W.Add('"');

      end;

      W.Add(':');

      W.AddVariant(VValue[ndx],twJSONEscape);

      W.Add(',');

    end;

    W.CancelLastComma;

    W.Add('}');

    W.SetText(result);

  finally

    W.Free;

  end;

end;



function TDocVariantData.GetValuesByStartName(const aStartName: RawUTF8;

  TrimLeftStartName: boolean): variant;

var Up: array[byte] of AnsiChar;

    ndx: integer;

    name: RawUTF8;

begin

  if aStartName='' then begin

    result := Variant(self);

    exit;

  end;

  if (Kind<>dvObject) 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 dvoReturnNullForOutOfRangeIndex 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 dvoReturnNullForOutOfRangeIndex in VOptions then

      SetVariantNull(Dest) else

      raise EDocVariant.CreateUTF8('Out of range Values[%] (count=%)',[Index,VCount]) else

    if DestByRef then

      SetVariantByRef(VValue[Index],Dest) else begin

      Source := @VValue[Index];

      while PVarData(Source)^.VType=varVariant or varByRef do

        Source := PVarData(Source)^.VPointer;

      Dest := Source^;

    end;

end;



procedure TDocVariantData.RetrieveValueOrRaiseException(

  aName: PUTF8Char; aNameLen: integer; aCaseSensitive: boolean;

  var Dest: variant; DestByRef: boolean);

var ndx: Integer;

begin

  ndx := GetValueIndex(aName,aNameLen,aCaseSensitive);

  if ndx<0 then

    if dvoReturnNullForUnknownProperty in VOptions then

      SetVariantNull(Dest) else

      raise EDocVariant.CreateUTF8('Unexpected "%" property',[aName]) else

    RetrieveValueOrRaiseException(ndx,Dest,DestByRef);

end;



function TDocVariantData.GetValueOrItem(const aNameOrIndex: Variant): Variant;

var wasString: boolean;

    Name: RawUTF8;

begin

  if VKind=dvArray 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 VKind=dvArray 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]);

    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 VKind=dvArray 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]);

end;



function TDocVariantData.ToJSON(const Prefix, Suffix: RawUTF8;

  Format: TTextWriterJSONFormat): RawUTF8;

var W: TTextWriter;

    tmp: RawUTF8;

begin

  W := DefaultTextWriterJSONClass.CreateOwnedStream;

  try

    W.AddString(Prefix);

    DocVariantType.ToJSON(W,variant(self),twJSONEscape);

    W.AddString(Suffix);

    W.SetText(result);

  finally

    W.Free;

  end;

  if Format=jsonCompact then

    exit;

  JSONBufferReformat(pointer(result),tmp,Format);

  result := tmp;

end;



function TDocVariantData.ToNonExpandedJSON: RawUTF8;

var fields: TRawUTF8DynArray;

    fieldsCount: integer;

    W: TTextWriter;

    r,f: integer;

    row: PDocVariantData;

begin

  fields := nil; // to please Kylix

  fieldsCount := 0;

  if VKind<>dvArray then begin

    result := '';

    exit;

  end;

  if VCount=0 then begin

    result := '[]';

    exit;

  end;

  with _Safe(VValue[0])^ do

    if VKind=dvObject then begin

      fields := VName;

      fieldsCount := VCount;

    end;

  if fieldsCount=0 then

    raise EDocVariant.Create('ToNonExpandedJSON: Value[0] is not an object');

  W := DefaultTextWriterJSONClass.CreateOwnedStream;

  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 ((row^.VKind<>dvObject) or (row^.VCount<>fieldsCount)) then

        raise EDocVariant.CreateUTF8('ToNonExpandedJSON: Value[%] not 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

  case VKind of

  dvUndefined: exit; // leave Result=[]

  dvArray: ;

  else raise EDocVariant.Create('ToRawUTF8DynArray expects a dvArray');

  end;

  SetLength(Result,VCount);

  for ndx := 0 to VCount-1 do

    VariantToUTF8(VValue[ndx],Result[ndx],wasString);

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;

begin

  case VKind of

  dvUndefined: exit; // leave result=''

  dvObject: ;

  else raise EDocVariant.Create('ToTextPairs expects a dvObject');

  end;

  if VCount=0 then

    exit;

  with DefaultTextWriterJSONClass.CreateOwnedStream(8192) 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=#13#10; escape: TTextWriterKind=twJSONEscape): RawUTF8;

begin

  ToTextPairsVar(result,NameValueSep,ItemSep,escape);

end;



procedure TDocVariantData.ToArrayOfConst(out Result: TTVarRecDynArray);

var ndx: integer;

begin

  case VKind of

  dvUndefined: exit; // leave Result=[]

  dvArray: ;

  else raise EDocVariant.Create('ToArrayOfConst expects a dvArray');

  end;

  SetLength(Result,VCount);

  for ndx := 0 to VCount-1 do begin

    Result[ndx].VType := vtVariant;

    Result[ndx].VVariant := @VValue[ndx];

  end;

end;



function TDocVariantData.ToArrayOfConst: TTVarRecDynArray;

begin

  ToArrayOfConst(result);

end;



function TDocVariantData.ToUrlEncode(const UriRoot: RawUTF8): RawUTF8;

var json: RawUTF8;

begin

  VariantSaveJSON(variant(self),twJSONEscape,json);

  result := UrlEncodeJsonObject(UriRoot,Pointer(json),[]);

end;



function TDocVariantData.GetOrAddValueIndex(const aName: RawUTF8): integer;

begin

  result := GetValueIndex(Pointer(aName),Length(aName),dvoNameCaseSensitive in VOptions);

  if result<0 then

    result := InternalAdd(aName);

end;



function TDocVariantData.GetVarDataByName(const aName: RawUTF8): PVariant;

var ndx: Integer;

begin

  ndx := GetValueIndex(pointer(aName),length(aName),dvoNameCaseSensitive in VOptions);

  if ndx<0 then

    if dvoReturnNullForUnknownProperty in VOptions then

      result := @DocVariantDataFake else

      raise EDocVariant.CreateUTF8('Unexpected "%" property',[aName]) else

    result := @VValue[ndx];

end;



function TDocVariantData.GetInt64ByName(const aName: RawUTF8): Int64;

begin

  if not VariantToInt64(GetVarDataByName(aName)^,result) then

    result := 0;

end;



function TDocVariantData.GetRawUTF8ByName(const aName: RawUTF8): RawUTF8;

var wasString: boolean;

    v: PVariant;

begin

  v := GetVarDataByName(aName);

  if PVarData(v)^.VType<=varNull then

    result := '' else

    VariantToUTF8(v^,result,wasString);

end;



procedure TDocVariantData.SetInt64ByName(const aName: RawUTF8;

  const aValue: Int64);

begin

  VValue[GetOrAddValueIndex(aName)] := aValue;

end;



procedure TDocVariantData.SetRawUTF8ByName(const aName, aValue: RawUTF8);

begin

  RawUTF8ToVariant(aValue,VValue[GetOrAddValueIndex(aName)]);

end;



function TDocVariantData.GetBooleanByName(const aName: RawUTF8): Boolean;

begin

  if not VariantToBoolean(GetVarDataByName(aName)^,result) then

    result := false;

end;



procedure TDocVariantData.SetBooleanByName(const aName: RawUTF8; aValue: Boolean);

begin

  VValue[GetOrAddValueIndex(aName)] := aValue;

end;



function TDocVariantData.GetDoubleByName(const aName: RawUTF8): Double;

begin

  if not VariantToDouble(GetVarDataByName(aName)^,result) then

    result := 0;

end;



procedure TDocVariantData.SetDoubleByName(const aName: RawUTF8;

  const aValue: Double);

begin

  VValue[GetOrAddValueIndex(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 := GetOrAddValueIndex(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)<cardinal(VCount) then

    result := _Safe(VValue[aIndex]) else

    if dvoReturnNullForOutOfRangeIndex in VOptions then

      result := @DocVariantDataFake else

      raise EDocVariant.CreateUTF8('Out of range _[%] (count=%)',[aIndex,VCount]);

end;





{ TDocVariant }



procedure TDocVariant.IntGet(var Dest: TVarData;

  const V: TVarData; Name: PAnsiChar);

procedure Execute(ndx: integer;

  const source: TDocVariantData; var Dest: variant);

begin

  case ndx of

  0: Dest := source.Count;

  1: Dest := ord(source.Kind);

  2: RawUTF8ToVariant(source.ToJSON,Dest);

  end;

end;

var NameLen, ndx: integer;

begin

  //Assert(V.VType=DocVariantVType);

  NameLen := StrLen(PUTF8Char(Name));

  // 1. search for any  _*  pseudo properties

  if (NameLen>4) and (Name[0]='_') then begin

    ndx := IdemPCharArray(@Name[1],['COUNT','KIND','JSON']);

    if ndx>=0 then begin

      Execute(ndx,TDocVariantData(V),variant(Dest));

      exit;

    end;

  end;

  // 2. case-insensitive search for aVariant.Name

  TDocVariantData(V).RetrieveValueOrRaiseException(

    PUTF8Char(Name),NameLen,false,variant(Dest),true);

end;



procedure TDocVariant.IntSet(const V, Value: TVarData; Name: PAnsiChar);

var ndx: Integer;

    aName: RawUTF8;

    Data: TDocVariantData absolute V;

begin

  if (Data.Kind=dvArray) and (PWord(Name)^=ord('_')) then begin

    ndx := Data.InternalAdd(''); // FPC does not allow VValue[InternalAdd(aName)]

    SetVariantByValue(variant(Value),Data.VValue[ndx]);

    exit;

  end;

  SetString(aName,Name,StrLen(PUTF8Char(Name)));

  ndx := Data.GetValueIndex(aName);

  if ndx<0 then

    ndx := Data.InternalAdd(aName);

  SetVariantByValue(variant(Value),Data.VValue[ndx]);

end;



function TDocVariant.IterateCount(const V: TVarData): integer;

var Data: TDocVariantData absolute V;

begin

  if Data.Kind<>dvArray then

    result := -1 else

    result := Data.VCount;

end;



procedure TDocVariant.Iterate(var Dest: TVarData; const V: TVarData; Index: integer);

var Data: TDocVariantData absolute V;

begin

  if (Data.Kind=dvArray) and (cardinal(Index)<cardinal(Data.VCount)) then

    Dest := TVarData(Data.VValue[Index]) else

    Dest.VType := varEmpty;

end;



function TDocVariant.DoFunction(var Dest: TVarData; const V: TVarData;

  const Name: string; const Arguments: TVarDataArray): boolean;

var ndx: integer;

    Data: TDocVariantData absolute V;

    temp: RawUTF8;

  procedure SetTempFromFirstArgument;

  var wasString: boolean;

  begin

    VariantToUTF8(variant(Arguments[0]),temp,wasString);

  end;

begin

  result := true;

  case length(Arguments) of

  0:if SameText(Name,'Clear') then begin

      PDocVariantData(@V)^.VCount := 0;

      PDocVariantData(@V)^.VKind := dvUndefined;

      exit;

    end;

  1:if SameText(Name,'Add') then begin

      ndx := Data.InternalAdd(''); // FPC does not allow VValue[InternalAdd(aName)]

      SetVariantByValue(variant(Arguments[0]),Data.VValue[ndx]);

      exit;

    end else

    if SameText(Name,'Delete') then begin

      SetTempFromFirstArgument;

      Data.Delete(Data.GetValueIndex(temp));

      exit;

    end else

    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:if SameText(Name,'Add') then begin

      SetTempFromFirstArgument;

      ndx := Data.InternalAdd(temp); // FPC does not allow VValue[InternalAdd(aName)]

      SetVariantByValue(variant(Arguments[1]),Data.VValue[ndx]);

      exit;

    end;

  end;

  result := false;

end;



procedure TDocVariant.ToJSON(W: TTextWriter; const Value: variant;

  escape: TTextWriterKind);

var ndx: integer;

    backup: TTextWriterOptions;

    checkExtendedPropName: boolean;

begin

  with TDocVariantData(Value) do

  if integer(VType)>varNull then

  if integer(VType)=DocVariantVType then

  if VKind=dvUndefined then

      W.AddShort('null') else begin

      backup := W.fCustomOptions;

      if [twoForceJSONExtended,twoForceJSONStandard]*backup=[] then

        if dvoSerializeAsExtendedJson in VOptions then

          include(W.fCustomOptions,twoForceJSONExtended) else

          include(W.fCustomOptions,twoForceJSONStandard);

      case VKind of

      dvObject: begin

        checkExtendedPropName := twoForceJSONExtended in W.CustomOptions;

        W.Add('{');

        for ndx := 0 to VCount-1 do begin

          if checkExtendedPropName and JsonPropNameValid(pointer(VName[ndx])) then begin

            W.AddNoJSONEscape(pointer(VName[ndx]),Length(VName[ndx]));

          end else begin

            W.Add('"');

            W.AddJSONEscape(pointer(VName[ndx]),Length(VName[ndx]));

            W.Add('"');

          end;

          W.Add(':');

          W.AddVariant(VValue[ndx],twJSONEscape);

          W.Add(',');

        end;

        W.CancelLastComma;

        W.Add('}');

      end;

      dvArray: begin

        W.Add('[');

        for ndx := 0 to VCount-1 do begin

          W.AddVariant(VValue[ndx],twJSONEscape);

          W.Add(',');

        end;

        W.CancelLastComma;

        W.Add(']');

      end;

    end;

    W.fCustomOptions := backup;

  end else

    raise ESynException.CreateUTF8('Unexpected variant type %',[VType]) else

    W.AddShort('null');

end;



procedure TDocVariant.Clear(var V: TVarData);

begin

  //Assert(V.VType=DocVariantVType);

  VariantDynArrayClear(TDocVariantData(V).VValue);

  TDocVariantData(V).VName := nil;

  ZeroFill(@V); // will set V.VType := varEmpty and VCount=0

end;



procedure TDocVariant.Copy(var Dest: TVarData; const Source: TVarData;

  const Indirect: Boolean);

begin

  //Assert(Source.VType=DocVariantVType);

  if Indirect then

    SimplisticCopy(Dest,Source,true) else

    if dvoValueCopiedByReference in TDocVariantData(Source).Options then begin

      if Dest.VType and VTYPE_STATIC<>0 then

        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);

  if Dest.VType and VTYPE_STATIC<>0 then

    VarClear(variant(Dest)); // Dest may be a complex type

  D.VType := S.VType;

  D.VOptions := S.VOptions;

  D.VKind := S.VKind;

  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

      if Dest.VType and VTYPE_STATIC<>0 then

        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

  if TVarData(result).VType and VTYPE_STATIC<>0 then

    VarClear(result);

  TDocVariantData(result).Init(Options);

end;



class function TDocVariant.NewObject(const NameValuePairs: array of const;

  Options: TDocVariantOptions=[]): variant;

begin

  if TVarData(result).VType and VTYPE_STATIC<>0 then

    VarClear(result);

  TDocVariantData(result).InitObject(NameValuePairs,Options);

end;



class function TDocVariant.NewArray(const Items: array of const;

  Options: TDocVariantOptions=[]): variant;

begin

  if TVarData(result).VType and VTYPE_STATIC<>0 then

    VarClear(result);

  TDocVariantData(result).InitArray(Items,Options);

end;



class function TDocVariant.NewArray(const Items: TVariantDynArray;

  Options: TDocVariantOptions=[]): variant;

begin

  if TVarData(result).VType and VTYPE_STATIC<>0 then

    VarClear(result);

  TDocVariantData(result).InitArrayFromVariants(Items,Options);

end;



class function TDocVariant.NewJSON(const JSON: RawUTF8;

  Options: TDocVariantOptions): variant;

begin

  _Json(JSON,result,Options);

end;



class function TDocVariant.NewUnique(const SourceDocVariant: variant;

  Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant;

begin

  if TVarData(result).VType and VTYPE_STATIC<>0 then

    VarClear(result);

  TDocVariantData(result).InitCopy(SourceDocVariant,Options);

end;



class procedure TDocVariant.GetSingleOrDefault(const docVariantArray, default: variant;

  var result: variant);

begin

  if TVarData(DocVariantArray).VType=varByRef or varVariant then

    GetSingleOrDefault(PVariant(TVarData(DocVariantArray).VPointer)^,default,result) else

  if (DocVariantType=nil) or

     (TVarData(DocVariantArray).VType<>DocVariantVType) or

     (TDocVariantData(DocVariantArray).Kind<>dvArray) or

     (TDocVariantData(DocVariantArray).Count<>1) then

    result := default else

    result := TDocVariantData(DocVariantArray).Values[0];

end;



function DocVariantData(const DocVariant: variant): PDocVariantData;

begin

  with TVarData(DocVariant) do

    if VType=word(DocVariantVType) then

      result := @DocVariant else

    if VType=varByRef or varVariant then

      result := DocVariantData(PVariant(VPointer)^) else

    raise EDocVariant.CreateUTF8('DocVariantType.Data(%<>TDocVariant)',[VType]);

end;



function _Safe(const DocVariant: variant): PDocVariantData;

{$ifndef HASINLINE}

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;

{$else}

begin

  with TVarData(DocVariant) do

    if VType=word(DocVariantVType) then begin

      result := @DocVariant;

      exit;

    end else

    if VType=varByRef or varVariant then begin

      result := _Safe(PVariant(VPointer)^);

      exit;

    end else begin

      result := @DocVariantDataFake;

      exit;

    end;

end;

{$endif}



function _Safe(const DocVariant: variant; ExpectedKind: TDocVariantKind): PDocVariantData; overload;

begin

  result := _Safe(DocVariant);

  if result^.Kind<>ExpectedKind then

    raise EDocVariant.CreateUTF8('_Safe(%)<>%',[ord(result^.Kind),ord(ExpectedKind)]);

end;



function _Obj(const NameValuePairs: array of const;

  Options: TDocVariantOptions=[]): variant;

begin

  if TVarData(result).VType and VTYPE_STATIC<>0 then

    VarClear(result);

  TDocVariantData(result).InitObject(NameValuePairs,Options);

end;



function _Arr(const Items: array of const;

  Options: TDocVariantOptions=[]): variant;

begin

  if TVarData(result).VType and VTYPE_STATIC<>0 then

    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 o^.VKind<>dvObject then begin

    if TVarData(Obj).VType and VTYPE_STATIC<>0 then

      VarClear(Obj);

    TDocVariantData(Obj).InitObject(NameValuePairs,JSON_OPTIONS_FAST);

  end else begin

    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 d.VKind=dvObject then

    if o.Kind<>dvObject 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

  if TVarData(result).VType and VTYPE_STATIC<>0 then

    VarClear(result);

  TDocVariantData(result).InitObject(NameValuePairs,JSON_OPTIONS_FAST);

end;



function _ObjFast(aObject: TObject; aOptions: TTextWriterWriteObjectOptions): variant;

begin

  if TVarData(result).VType and VTYPE_STATIC<>0 then

    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

  if TVarData(result).VType and VTYPE_STATIC<>0 then

    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 _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); overload;

begin

  if TDocVariantData(result).InitJSONInPlace(

     pointer(FormatUTF8(Format,Args,Params,true)),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

  if TVarData(Value).VType and VTYPE_STATIC<>0 then

    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;



{$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}



function DynArrayLoad(var Value; Source: PAnsiChar; TypeInfo: pointer): PAnsiChar;

var DynArray: TDynArray;

begin

  DynArray.Init(TypeInfo,Value);

  result := DynArray.LoadFrom(Source);

end;



function DynArraySave(var Value; TypeInfo: pointer): RawByteString;

var DynArray: TDynArray;

begin

  DynArray.Init(TypeInfo,Value);

  result := DynArray.SaveTo;

end;



function DynArrayLoadJSON(var Value; JSON: PUTF8Char; TypeInfo: pointer;

  EndOfObject: PUTF8Char=nil): PUTF8Char;

var DynArray: TDynArray;

begin

  DynArray.Init(TypeInfo,Value);

  result := DynArray.LoadFromJSON(JSON,EndOfObject);

end;



function DynArraySaveJSON(const Value; TypeInfo: pointer;

  EnumSetsAsText: boolean): RawUTF8;

begin

  SaveJSON(Value,TypeInfo,EnumSetsAsText,result);

end;



function DynArraySaveJSON(TypeInfo: pointer; const BlobValue: RawByteString): RawUTF8;

var DynArray: TDynArray;

    Value: pointer;

begin

  Value := nil;

  DynArray.Init(TypeInfo,Value);

  try

    if DynArray.LoadFrom(pointer(BlobValue))=nil then

      result := '' else begin

      with DefaultTextWriterJSONClass.CreateOwnedStream(8192) do

      try

        AddDynArrayJSON(TypeInfo,Value);

        SetText(result);

      finally

        Free;

      end;

     end;

  finally

    DynArray.Clear;

  end;

end;



function DynArrayElementTypeName(TypeInfo: pointer; ElemTypeInfo: PPointer): RawUTF8;

var DynArray: TDynArray;

    VoidArray: pointer;

const KNOWNTYPE_ITEMNAME: array[TDynArrayKind] of RawUTF8 = ('',

  'boolean','byte','word','integer','cardinal','single','Int64','double','currency',

  'TTimeLog','TDateTime','RawUTF8','WinAnsiString','string','RawByteString',

  'WideString','SynUnicode','IInterface',{$ifndef NOVARIANTS}'variant',{$endif}'');

begin

  VoidArray := nil;

  DynArray.Init(TypeInfo,VoidArray);

  result := '';

  if ElemTypeInfo<>nil then

    ElemTypeInfo^ := DynArray.ElemType;

  if DynArray.ElemType<>nil then

    TypeInfoToName(ElemTypeInfo,result) else

    result := KNOWNTYPE_ITEMNAME[DynArray.ToKnownType];

end;



function SortDynArrayBoolean(const A,B): integer;

begin

  if boolean(A)=boolean(B) then

    result := 0 else

  if boolean(A) then

    result := 1 else

    result := -1;

end;



function SortDynArrayByte(const A,B): integer;

begin

  result := byte(A)-byte(B);

end;



function SortDynArrayWord(const A,B): integer;

begin

  result := word(A)-word(B);

end;



function SortDynArrayInteger(const A,B): integer;

begin

  result := Integer(A)-Integer(B);

end;



function SortDynArrayCardinal(const A,B): integer;

begin

  if cardinal(A)<cardinal(B) then

    result := -1 else

  if cardinal(A)>cardinal(B) then

    result := 1 else

    result := 0;

end;



function SortDynArrayInt64(const A,B): integer;

var tmp: Int64;

begin

  tmp := Int64(A)-Int64(B);

  if tmp<0 then

    result := -1 else

  if tmp>0 then

    result := 1 else

    result := 0;

end;



function SortDynArrayPointer(const A,B): integer;

begin

  {$ifdef CPU64}

  if PtrInt(A)<PtrInt(B) then

    result := -1 else

  if PtrInt(A)>PtrInt(B) then

    result := 1 else

    result := 0;

  {$else}

  result := PtrInt(A)-PtrInt(B);

  {$endif}

end;



function SortDynArraySingle(const A,B): integer;

begin

  if Single(A)<Single(B) then

    result := -1 else

  if Single(A)>Single(B) then

    result := 1 else

    result := 0;

end;



function SortDynArrayDouble(const A,B): integer;

begin

  if Double(A)<Double(B) then

    result := -1 else

  if Double(A)>Double(B) then

    result := 1 else

    result := 0;

end;



function SortDynArrayAnsiString(const A,B): integer;

{$ifdef PUREPASCAL}

begin

  result := StrComp(pointer(A),pointer(B));

end;

{$else}

asm // x86 version optimized for RawByteString/AnsiString/RawUTF8 types

    mov  eax,[eax]

    mov  edx,[edx]

    cmp  eax,edx

    je   @0

    test eax,edx

    jz   @n1

@n2:movzx ecx,byte ptr [eax] // first char comparison (QuickSort speedup)

    sub  cl,[edx]

    jne  @no

    push ebx

    mov  ebx,[eax-4]

    sub  ebx,[edx-4]

    push ebx

    adc  ecx,-1

    and  ecx,ebx

    sub  ecx,[eax-4]

    sub  eax,ecx

    sub  edx,ecx

@s: mov  ebx,[eax+ecx]  // compare by DWORD

    xor  ebx,[edx+ecx]

    jnz  @d

    add  ecx,4

    js   @s

@L: pop  eax            // all chars equal -> returns length(A)-length(B)

    pop  ebx

    ret

@d: bsf  ebx,ebx        // char differs -> returns PByte(A)^-PByte(B)^

    shr  ebx,3

    add  ecx,ebx

    jns  @L

    movzx eax,byte ptr [eax+ecx]

    movzx edx,byte ptr [edx+ecx]

    pop  ebx

    pop  ebx

    sub  eax,edx

    ret

@n1:test eax,eax       // A or B may be ''

    jz   @n0

    test edx,edx

    jnz  @n2

    cmp  [eax-4],edx

    je   @0

@no:jnc  @1

    or   eax,-1

    ret

@n0:cmp  eax,[edx-4]

    je   @0

    jnc  @1

    or   eax,-1

    ret

@0: xor  eax,eax

    ret

@1: mov  eax,1

end;

{$endif}



function SortDynArrayAnsiStringI(const A,B): integer;

begin

  result := StrIComp(PUTF8Char(A),PUTF8Char(B));

end;



function SortDynArrayPUTF8Char(const A,B): integer;

begin

  result := StrComp(pointer(A),pointer(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 := SysUtils.StrComp(PChar(A),PChar(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 SortDynArrayUnicodeString(const A,B): integer;

begin

  result := StrCompW(PWideChar(A),PWideChar(B));

end;



function SortDynArrayUnicodeStringI(const A,B): integer;

begin

  result := AnsiICompW(PWideChar(A),PWideChar(B));

end;



{$ifndef NOVARIANTS}



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 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);

begin

  if A.VType=varVariant or varByRef then

    result := SortDynArrayVariantComp(PVarData(A.VPointer)^,B,caseInsensitive) else

  if B.VType=varVariant or varByRef then

    result := SortDynArrayVariantComp(A,PVarData(B.VPointer)^,caseInsensitive) else

  if A.VType=B.VType then

    case A.VType of // optimized value comparison if A and B share the same type

    varNull,varEmpty:

      result := 0;

    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);

    varInteger:

      result := A.VInteger-B.VInteger;

    varInt64,varCurrency:

      if A.VInt64<B.VInt64 then

        result := -1 else

      if A.VInt64>B.VInt64 then

        result := 1 else

        result := 0;

    varDouble:

      if A.VDouble<B.VDouble then

        result := -1 else

      if A.VDouble>B.VDouble then

        result := 1 else

        result := 0;

    varBoolean:

      result := ord(A.VBoolean)-ord(B.VBoolean);

    varOleStr{$ifdef HASVARUSTRING},varUString{$endif}:

      if caseInsensitive then

        result := AnsiICompW(A.VAny,B.VAny) else

        result := StrCompW(A.VAny,B.VAny);

    else

      if A.VType and VTYPE_STATIC=0 then

        result := ICMP[VarCompareValue(variant(A),variant(B))] else

        result := CMP[caseInsensitive](variant(A),variant(B));

    end else

    if (A.VType and VTYPE_STATIC=0) and

       (B.VType and VTYPE_STATIC=0) then

      result := ICMP[VarCompareValue(variant(A),variant(B))] else

      result := CMP[caseInsensitive](variant(A),variant(B));

end;



function SortDynArrayVariant(const A,B): integer;

begin

  result := SortDynArrayVariantComp(TVarData(A),TVarData(B),false);

end;



function SortDynArrayVariantI(const A,B): integer;

begin

  result := SortDynArrayVariantComp(TVarData(A),TVarData(B),true);

end;



{$endif NOVARIANTS}



function TDynArray.Add(const Elem): integer;

begin

  result := Count;

  if fValue=nil then

    exit; // avoid GPF if void

  SetCount(result+1);

  ElemCopy(Elem,pointer(PtrUInt(fValue^)+PtrUInt(result)*ElemSize)^);

end;



function TDynArray.New: integer;

begin

  result := Count;

  if fValue=nil then

    exit; // avoid GPF if void

  SetCount(result+1);

end;



procedure TDynArray.Insert(Index: Integer; const Elem);

var n: integer;

    P: PByteArray;

begin

  if fValue=nil then

    exit; // avoid GPF if void

  n := Count;

  SetCount(n+1);

  if cardinal(Index)<cardinal(n) then begin

    P := pointer(PtrUInt(fValue^)+PtrUInt(Index)*ElemSize);

    MoveFast(P[0],P[ElemSize],cardinal(n-Index)*ElemSize);

    if ElemType<>nil then

      FillcharFast(P[0],ElemSize,0); // avoid GPF in ElemCopy() below

  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;



procedure TDynArray.Delete(aIndex: Integer);

var n, len: integer;

    P: PAnsiChar;

    zerolast: boolean;

begin

  if fValue=nil then

    exit; // avoid GPF if void

  n := Count;

  if cardinal(aIndex)>=cardinal(n) then

    exit; // out of range

  dec(n);

  P := pointer(PtrUInt(fValue^)+PtrUInt(aIndex)*ElemSize);

  if ElemType<>nil then begin

    _Finalize(P,ElemType);

    zerolast := true;

  end else

    if GetIsObjArray then begin

      FreeAndNil(PObject(P)^);

      zerolast := true;

    end else

    zerolast := false;

  if n>aIndex then begin

    len := cardinal(n-aIndex)*ElemSize;

    MoveFast(P[ElemSize],P[0],len);

    if zerolast then // avoid GPF

      FillcharFast(P[len],ElemSize,0);

  end;

  SetCount(n);

end;



function TDynArray.ElemPtr(aIndex: integer): pointer;

begin

  result := nil;

  if (fValue=nil) or (fValue^=nil) then

    exit;

  if fCountP<>nil then begin

    if cardinal(aIndex)>=PCardinal(fCountP)^ then

      exit;

  end else

    {$ifdef FPC}

    if cardinal(aIndex)>=cardinal(PDynArrayRec(PtrUInt(fValue^)-SizeOf(TDynArrayRec))^.length) then

    {$else}

    if cardinal(aIndex)>=PCardinal(PtrUInt(fValue^)-sizeof(PtrInt))^ then

    {$endif}

      exit;

  result := pointer(PtrUInt(fValue^)+PtrUInt(aIndex)*ElemSize);

end;



function TDynArray.GetCount: integer;

begin

  if fValue<>nil then

    if fCountP=nil then

      if PtrInt(fValue^)<>0 then begin

        {$ifdef FPC}

        result := PDynArrayRec(PtrUInt(fValue^)-SizeOf(TDynArrayRec))^.length;

        {$else}

        result := PInteger(PtrUInt(fValue^)-sizeof(PtrInt))^;

        {$endif}

        exit;

      end else begin

        result := 0;

        exit;

      end else begin

      result := fCountP^;

      exit;

    end else begin

    result := 0; // avoid GPF if void

    exit;

  end;

end;



procedure TDynArray.Reverse;

var i, siz, n, tmp: integer;

    P1, P2: PAnsiChar;

    c: AnsiChar;

    i64: Int64;

begin

  n := Count-1;

  if n>0 then begin

    siz := ElemSize;

    P1 := fValue^;

    case siz of

    1: begin

      // optimized version for TByteDynArray and such

      P2 := P1+n;

      for i := 1 to n shr 1 do begin

        c := P1^;

        P1^ := P2^;

        P2^ := c;

        inc(P1);

        dec(P2);

      end;

    end;

    4: begin

      // optimized version for TIntegerDynArray + TRawUTF8DynArray and such

      P2 := P1+n*sizeof(Integer);

      for i := 1 to n shr 1 do begin

        tmp := PInteger(P1)^;

        PInteger(P1)^ := PInteger(P2)^;

        PInteger(P2)^ := tmp;

        inc(P1,4);

        dec(P2,4);

      end;

    end;

    8: begin

      // optimized version for TInt64DynArray + TDoubleDynArray and such

      P2 := P1+n*sizeof(Int64);

      for i := 1 to n shr 1 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 TVariantDynArray and such

      P2 := P1+n*16;

      for i := 1 to n shr 1 do begin

        Exchg16(Pointer(P1),Pointer(P2));

        inc(P1,16);

        dec(P2,16);

      end;

    end;

    else begin

      // generic version

      P2 := P1+n*siz;

      for i := 1 to n shr 1 do begin

        Exchg(P1,P2,siz);

        inc(P1,siz);

        dec(P2,siz);

      end;

    end;

    end;

  end;

end;



procedure TDynArray.SaveToStream(Stream: TStream);

var Posi, PosiEnd: Integer;

    MemStream: TCustomMemoryStream absolute Stream;

    tmp: RawByteString;

begin

  if (fValue=nil) or (Stream=nil) then

    exit; // avoid GPF if void

  if Stream.InheritsFrom(TCustomMemoryStream) then begin

    Posi := MemStream.Seek(0,soFromCurrent);

    PosiEnd := Posi+SaveToLength;

    if PosiEnd>MemStream.Size then

      MemStream.Size := PosiEnd;

    if SaveTo(PAnsiChar(MemStream.Memory)+Posi)-MemStream.Memory<>PosiEnd then

      EStreamError.Create('TDynArray.SaveToStream');

    MemStream.Seek(PosiEnd,soBeginning);

  end else begin

    tmp := SaveTo;

    Stream.Write(pointer(tmp)^,length(tmp));

  end;

end;



procedure TDynArray.LoadFromStream(Stream: TCustomMemoryStream);

var P: PAnsiChar;

begin

  P := PAnsiChar(Stream.Memory)+Stream.Seek(0,soFromCurrent);

  Stream.Seek(LoadFrom(P)-P,soCurrent);

end;



function TDynArray.SaveTo(Dest: PAnsiChar): PAnsiChar;

var i, n, LenBytes: integer;

    P: PAnsiChar;

    nested: PTypeInfo;

    NestedArray: TDynArray;

begin

  if fValue=nil then begin

    result := Dest;

    exit; // avoid GPF if void

  end;

  // first store the element size+type to check for the format (name='' mostly)

  Dest := pointer(ToVarUInt32(ElemSize,pointer(Dest)));

  if ElemType=nil then

    Dest^ := #0 else

    Dest^ := PAnsiChar(ElemType)^;

  inc(Dest);

  // then store dynamic array count

  n := Count;

  Dest := pointer(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

    if GetIsObjArray then

      raise ESynException.CreateUTF8('TDynArray.SaveTo(%) is a T*ObjArray',

        [PShortString(@PTypeInfo(ArrayType).NameLen)^]) else begin

      // binary types: store as once

      n := n*integer(ElemSize);

      MoveFast(P^,Dest^,n);

      inc(Dest,n);

    end else

    case PTypeKind(ElemType)^ of

    tkLString, tkWString {$ifdef HASVARUSTRING}, tkUString{$endif}

    {$ifdef FPC}, tkLStringOld{$endif}: begin

      for i := 1 to n do begin

        if PPtrUInt(P)^=0 then

          LenBytes := 0 else begin

          LenBytes := PStrRec(Pointer(PPtrUInt(P)^-STRRECSIZE))^.length;

          {$ifdef HASVARUSTRING} // WideString length in bytes, UnicodeString in WideChars

          if PTypeKind(ElemType)^=tkUString then

            LenBytes := LenBytes*2;

          {$endif}

        end;

        Dest := pointer(ToVarUInt32(LenBytes,pointer(Dest)));

        if LenBytes>0 then begin

          MoveFast(pointer(PPtrUInt(P)^)^,Dest^,LenBytes);

          inc(Dest,LenBytes);

        end;

        inc(P,sizeof(PtrUInt));

      end;

    end;

    {$ifndef NOVARIANTS}

    tkVariant:

      for i := 0 to n-1 do begin

        Dest := VariantSave(PVariantArray(P)^[i],Dest);

        if Dest=nil then

          break; // invalid/unhandled variant content

      end;

    {$endif}

    tkRecord{$ifdef FPC},tkObject{$endif}: begin

      nested := ElemType; // inlined GetTypeInfo()

      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

      nested := GetFPCAlignPtr(nested);

      {$else}

      inc(PtrUInt(nested),nested^.NameLen);

      {$endif}

      if nested^.ManagedCount=0 then begin

        {$ifndef LVCL}

        assert(nested^.recSize=ElemSize);

        {$endif}

        n := n*integer(ElemSize);

        MoveFast(P^,Dest^,n);

        inc(Dest,n);

      end else begin

        for i := 1 to n do begin

          Dest := RecordSave(P^,Dest,ElemType);

          if Dest=nil then

            break; // invalid record type (wrong field type)

          inc(P,ElemSize);

        end;

      end;

    end;

    tkDynArray:

      for i := 1 to n do begin

        NestedArray.Init(ElemType,P^);

        Dest := NestedArray.SaveTo(Dest);

        inc(P,ElemSize);

      end;

  end;

  // store Hash32 checksum

  if Dest<>nil then  // may be nil if RecordSave() failed

    PCardinal(result-sizeof(Cardinal))^ := Hash32(result,Dest-result);

  result := Dest;

end;



function TDynArray.SaveToLength: integer;

var i,n,L: integer;

    P: PAnsiChar;

    NestedArray: TDynArray;

begin

  if fValue=nil then begin

    result := 0;

    exit; // avoid GPF if void

  end;

  n := Count;

  result := ToVarUInt32Length(ElemSize)+ToVarUInt32Length(n)+1;

  if n=0 then

    exit;

  if ElemType=nil then

    if GetIsObjArray then

      raise ESynException.CreateUTF8('TDynArray.SaveToLength(%) is a T*ObjArray',

        [PShortString(@PTypeInfo(ArrayType).NameLen)^]) else

      inc(result,integer(ElemSize)*n) else begin

    P := fValue^;

    case PTypeKind(ElemType)^ of

    tkLString, tkWString{$ifdef FPC}, tkLStringOld{$endif}:

      for i := 1 to n do begin

        if PPtrUInt(P)^=0 then

          inc(result) else

          inc(result,ToVarUInt32LengthWithData(PStrRec(Pointer(PPtrUInt(P)^-STRRECSIZE))^.length));

        inc(P,sizeof(PtrUInt));

      end;

    {$ifdef HASVARUSTRING}

    tkUString: // WideString has length in bytes, UnicodeString in WideChars

      for i := 1 to n do begin

        if PPtrUInt(P)^=0 then

          inc(result) else

          inc(result,ToVarUInt32LengthWithData(PStrRec(Pointer(PPtrUInt(P)^-STRRECSIZE))^.length*2));

        inc(P,sizeof(PtrUInt));

      end;

    {$endif}

    {$ifndef NOVARIANTS}

    tkVariant:

      for i := 0 to n-1 do begin

        L := VariantSaveLength(PVariantArray(P)^[i]);

        if L=0 then

          break; // invalid/unhandled variant content

        inc(result,L);

      end;

    {$endif}

    tkRecord{$ifdef FPC},tkObject{$endif}:

      for i := 1 to n do begin

        L := RecordSaveLength(P^,ElemType);

        if L=0 then

          break; // invalid record type (wrong field type)

        inc(result,L);

        inc(P,ElemSize);

      end;

    tkDynArray:

      for i := 1 to n do begin

        NestedArray.Init(ElemType,P^);

        inc(result,NestedArray.SaveToLength);

        inc(P,ElemSize);

      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): RawUTF8;

begin

  with DefaultTextWriterJSONClass.CreateOwnedStream(8192) do

  try

    if EnumSetsAsText then

      CustomOptions := CustomOptions+[twoEnumSetsAsTextInRecord];

    AddDynArrayJSON(self);

    SetText(result);

  finally

    Free;

  end;

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 not(P^ in [#1..' ']);

  until false;

  if P^=']' then

    result := n;

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);

      while P^<>']' do begin

        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 not(P^ in [#1..' ']);

        dec(Index);

      end;

    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<PMax do begin

    case P^ of

    '"': begin

      P := GotoEndOfJSONString(P);

      if 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 not(P^ in [#1..' ']);

  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 not(P^ in [#1..' ']);

  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);

      while P^<>'}' do begin

        GetJSONPropName(P,name);

        if (name[0]=#0) or (name[0]>#200) then

          break;

        if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

        if PropNameLen=0 then begin

          name[ord(name[0])+1] := #0; // make ASCIIZ

          if IdemPChar(@name[1],PropNameUpper) then begin

            if PropNameFound<>nil then

              PropNameFound^ := name;

            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 not(P^ in [#1..' ']);

      end;

    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

    objName := GetNextItem(PropPath,'.');

    if objName='' then

      exit;

    JsonObject := JsonObjectItem(JsonObject,objName);

    if JsonObject=nil then

      exit;

    if PropPath=nil then

      break; // found full name scope

  until false;

  result := JsonObject;

end;



function JsonObjectsByPath(JsonObject,PropPath: PUTF8Char): RawUTF8;

var itemName,objName,propNameFound,objPath: RawUTF8;

    start,ending,obj: PUTF8Char;

    WR: TTextWriter;

  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;

      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

      itemName := GetNextItem(PropPath,',');

      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

          objName := GetNextItem(obj,'.');

          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;

begin

  result := false;

  if (JSON=nil) or (JSON^<>'{') then

    exit;

  wk := TTextWriter.CreateOwnedStream(8192);

  wv := TTextWriter.CreateOwnedStream(8192);

  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;



const

  PTRSIZ = sizeof(Pointer);

  KNOWNTYPE_SIZE: array[TDynArrayKind] of byte = (

    0, 1,1, 2, 4,4,4, 8,8,8,8,8, PTRSIZ,PTRSIZ,PTRSIZ,PTRSIZ,PTRSIZ,PTRSIZ,PTRSIZ,

    {$ifndef NOVARIANTS}sizeof(Variant),{$endif} 0);



function TDynArray.GetArrayTypeName: RawUTF8;

begin

  TypeInfoToName(fTypeInfo,result);

end;



function TDynArray.ToKnownType(exactType: boolean): TDynArrayKind;

var nested: PTypeInfo;

label Bin, Rec;

begin

  if fKnownType<>djNone then begin

    result := fKnownType;

    exit;

  end;

  case ElemSize of

  1: if fTypeInfo=TypeInfo(TBooleanDynArray) then

       fKnownType := djBoolean;

  4: if fTypeInfo=TypeInfo(TCardinalDynArray) then

       fKnownType := djCardinal else

     if fTypeInfo=TypeInfo(TSingleDynArray) then

       fKnownType := djSingle

  {$ifdef CPU64} ; 8: {$else} else {$endif}

    if fTypeInfo=TypeInfo(TRawUTF8DynArray) then

      fKnownType := djRawUTF8 else

    if fTypeInfo=TypeInfo(TStringDynArray) then

      fKnownType := djString else

    if fTypeInfo=TypeInfo(TWinAnsiDynArray) then

      fKnownType := djWinAnsi else

    if fTypeInfo=TypeInfo(TRawByteStringDynArray) then

      fKnownType := djRawByteString else

    if fTypeInfo=TypeInfo(TSynUnicodeDynArray) then

      fKnownType := djSynUnicode else

    {$ifndef DELPHI5OROLDER}

    if fTypeInfo=TypeInfo(TInterfaceDynArray) then

      fKnownType := djInterface

    {$endif}

  {$ifdef CPU64} else {$else} ; 8: {$endif}

     if fTypeInfo=TypeInfo(TDoubleDynArray) then

       fKnownType := djDouble else

     if fTypeInfo=TypeInfo(TCurrencyDynArray) then

       fKnownType := djCurrency else

     if fTypeInfo=TypeInfo(TTimeLogDynArray) then

       fKnownType := djTimeLog else

     if fTypeInfo=TypeInfo(TDateTimeDynArray) then

       fKnownType := djDateTime;

  end;

  if (fKnownType=djNone) and not exactType then begin

    fKnownSize := 0;

    if ElemType=nil then

Bin:  case ElemSize of

      1: fKnownType := djByte;

      2: fKnownType := djWord;

      4: fKnownType := djInteger;

      8: fKnownType := djInt64;

      else fKnownSize := ElemSize;

      end else

    case PTypeKind(ElemType)^ of

      tkLString{$ifdef FPC},tkLStringOld{$endif}: fKnownType := djRawUTF8;

      tkWString: fKnownType := djWideString;

      {$ifdef UNICODE}

      tkUString: fKnownType := djString;

      {$endif}

      {$ifndef NOVARIANTS}

      tkVariant: fKnownType := djVariant;

      {$endif}

      tkInterface: fKnownType := djInterface;

      tkRecord{$ifdef FPC},tkObject{$endif}: begin

        nested := ElemType; // inlined GetTypeInfo()

        {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

rec:    nested := GetFPCAlignPtr(nested);

        {$else}

rec:    inc(PtrUInt(nested),(nested^.NameLen));

        {$endif}

        if nested^.ManagedCount=0 then // only binary content -> full content

          goto Bin;

        with nested^.ManagedFields[0] do

        case Offset of

        0: case TypeInfo^.Kind of

            tkLString{$ifdef FPC},tkLStringOld{$endif}: fKnownType := djRawUTF8;

            tkWString: fKnownType := djWideString;

            {$ifdef UNICODE}

            tkUString: fKnownType := djString;

            {$endif}

            tkRecord{$ifdef FPC},tkObject{$endif}: begin

              nested := Deref(TypeInfo);

              goto Rec;

            end;

            {$ifndef NOVARIANTS}

            tkVariant: fKnownType := djVariant;

            {$endif}

            else begin

              {$ifdef FPC} // unmanaged fields have RTTI in newest FPC! :)

              if (nested^.ManagedCount<>1) and // emulate Delphi behavior

                 (nested^.ManagedFields[1].TypeInfo^.Kind in tkManagedTypes) then

              case nested^.ManagedFields[1].Offset of

                1: fKnownType := djByte;

                2: fKnownType := djWord;

                4: fKnownType := djInteger;

                8: fKnownType := djInt64;

                else fKnownSize := nested^.ManagedFields[1].Offset;

              end else

              {$endif}

              goto bin;

            end;

           end;

        1: fKnownType := djByte;

        2: fKnownType := djWord;

        4: fKnownType := djInteger;

        8: fKnownType := djInt64;

        else fKnownSize := Offset;

        end;

      end;

    end;

  end;

  if KNOWNTYPE_SIZE[fKnownType]<>0 then

    fKnownSize := KNOWNTYPE_SIZE[fKnownType];

  result := fKnownType;

end;



function TDynArray.LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char=nil): PUTF8Char;

var n, i: integer;

    T: TDynArrayKind;

    wasString, expectedString, isValid: boolean;

    EndOfObject: AnsiChar;

    Val: PUTF8Char;

    CustomReader: TDynArrayJSONCustomReader;

    NestedDynArray: TDynArray;

begin // code below must match TTextWriter.AddDynArrayJSON()

  result := nil;

  if (P=nil) or (fValue=nil) then

    exit;

  if not NextNotSpaceCharIs(P,'[') then

    exit;

  n := JSONArrayCount(P);

  if n<0 then

    exit; // invalid array content

  if n=0 then begin

    if NextNotSpaceCharIs(P,']') then begin

      Clear;

      result := P;

    end;

    exit; // handle '[]' array

  end;

  if GlobalJSONCustomParsers.DynArraySearch(ArrayType,ElemType,CustomReader) then

    T := djCustom else

    T := ToKnownType;

  if (T=djNone) and (P^='[') and (PTypeKind(ElemType)^=tkDynArray) then begin

    Count := n; // fast allocation of the whole dynamic array memory at once

    for i := 0 to n-1 do begin

      NestedDynArray.Init(ElemType,PPointerArray(fValue^)^[i]);

      P := NestedDynArray.LoadFromJSON(P,@EndOfObject);

      if P=nil then

        exit;

      EndOfObject := P^; // ',' or ']' for the last item of the array

      inc(P);

    end;

  end else

  if (T=djNone) or

     (PCardinal(P)^=JSON_BASE64_MAGIC_QUOTE) then begin

    if n<>1 then

      exit; // expect one Base64 encoded string value preceded by \uFFF0

    Val := GetJSONField(P,P,@wasString,@EndOfObject);

    if (Val=nil) or (not wasString) or

       (PInteger(Val)^ and $00ffffff<>JSON_BASE64_MAGIC) or

       (LoadFrom(pointer(Base64ToBin(Val+3)))=nil) then

      exit; // invalid content

  end else begin

    if GetIsObjArray then

      for i := 0 to Count-1 do // force release any previous instance

        FreeAndNil(PObjectArray(fValue^)^[i]);

    SetCount(n); // fast allocation of the whole dynamic array memory at once

    case T of

    {$ifndef NOVARIANTS}

    djVariant:

      for i := 0 to n-1 do

        P := VariantLoadJSON(PVariantArray(fValue^)^[i],P,@EndOfObject,@JSON_OPTIONS[true]);

    {$endif}

    djCustom: begin

      Val := fValue^;

      for i := 1 to n do begin

        P := CustomReader(P,Val^,isValid);

        if not isValid then

          exit;

        EndOfObject := P^; // ',' or ']' for the last item of the array

        inc(P);

        inc(Val,ElemSize);

      end;

    end;

    else begin

      expectedString := (T in [djTimeLog..djSynUnicode]);

      for i := 0 to n-1 do begin

        Val := GetJSONField(P,P,@wasString,@EndOfObject);

        if (Val=nil) or (wasString<>expectedString) then

          exit;

        case T of

        djBoolean:  PBooleanArray(fValue^)^[i] := GetBoolean(Val); 

        djByte:     PByteArray(fValue^)^[i] := GetCardinal(Val);

        djWord:     PWordArray(fValue^)^[i] := GetCardinal(Val);

        djInteger:  PIntegerArray(fValue^)^[i] := GetInteger(Val);

        djCardinal: PCardinalArray(fValue^)^[i] := GetCardinal(Val);

        djSingle:   PSingleArray(fValue^)^[i] := GetExtended(Val);

        djInt64:    SetInt64(Val,PInt64Array(fValue^)^[i]);

        djTimeLog:  PInt64Array(fValue^)^[i] := Iso8601ToTimeLogPUTF8Char(Val,0);

        djDateTime: Iso8601ToDateTimePUTF8CharVar(Val,0,TDateTime(PDoubleArray(fValue^)^[i]));

        djDouble:   PDoubleArray(fValue^)^[i] := GetExtended(Val);

        djCurrency: PInt64Array(fValue^)^[i] := StrToCurr64(Val);

        djRawUTF8:  RawUTF8(PPointerArray(fValue^)^[i]) := Val;

        djRawByteString:

          if not Base64MagicCheckAndDecode(Val,PRawByteStringArray(fValue^)^[i]) then

            RawUTF8(PPointerArray(fValue^)^[i]) := Val;

        djWinAnsi:  WinAnsiConvert.UTF8BufferToAnsi(Val,StrLen(Val),PRawByteStringArray(fValue^)^[i]);

        djString:   UTF8DecodeToString(Val,StrLen(Val),string(PPointerArray(fValue^)^[i]));

        djWideString: UTF8ToWideString(Val,StrLen(Val),WideString(PPointerArray(fValue^)^[i]));

        djSynUnicode: UTF8ToSynUnicode(Val,StrLen(Val),SynUnicode(PPointerArray(fValue^)^[i]));

        djInterface: raise ESynException.Create('djInterface not readable');

        end;

      end;

    end;

    end;

  end;

  if aEndOfObject<>nil then

    aEndOfObject^ := EndOfObject;

  if EndOfObject=']' then

    if P=nil then

      result := @NULCHAR else

      result := P;

end;



function SimpleDynArrayLoadFrom(Source: PAnsiChar; aTypeInfo: pointer;

  var Count, ElemSize: integer): pointer;

var Hash: PCardinalArray absolute Source;

    info: PTypeInfo;

begin

  result := nil;

  info := GetTypeInfo(aTypeInfo,tkDynArray);

  if info=nil then

    exit; // invalid type information

  if (info^.ElType<>nil) or (Source=nil) or

     (Source[0]<>AnsiChar(info^.elSize)) or (Source[1]<>#0) then

    exit; // invalid type information or Source content

  ElemSize := info^.elSize {$ifdef FPC}and $7FFFFFFF{$endif};

  inc(Source,2);

  Count := FromVarUInt32(PByte(Source)); // dynamic array count

  if (Count<>0) and (Hash32(@Hash[1],

      Count*info^.elSize {$ifdef FPC}and $7FFFFFFF{$endif})=Hash[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 (Source[1]<>#0) then

    exit; // invalid Source content

  inc(Source,2);

  Count := FromVarUInt32(PByte(Source)); // dynamic array count

  if (Count<>0) and (Hash32(@Hash[1],Count*sizeof(Integer))=Hash[0]) then

    result := @Hash[1]; // returns valid Source content

end;



function RawUTF8DynArrayLoadFromContains(Source: PAnsiChar;

  Value: PUTF8Char; ValueLen: integer; CaseSensitive: boolean): integer;

var Count, Len: integer;

begin

  if (Value=nil) or (ValueLen=0) or

     (Source=nil) or (Source[0]<>AnsiChar(sizeof(PtrInt))) or

     (Source[1]<>AnsiChar(tkLString)) 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 security checksum

  for result := 0 to Count-1 do begin

    Len := FromVarUInt32(PByte(Source));

    if CaseSensitive then begin

      if (Len=ValueLen) and CompareMem(Value,Source,Len) then

        exit;

    end else

      if UTF8ILComp(Value,pointer(Source),ValueLen,Len)=0 then

        exit;

    inc(Source,Len);

  end;

  result := -1;

end;



function TDynArray.LoadFrom(Source: PAnsiChar): PAnsiChar;

var i, n, LenBytes: integer;

    P: PAnsiChar;

    infoNested: PTypeInfo;

    Hash: PCardinalArray;

    NestedArray: TDynArray;

begin

  // check stored element size+type

  if Source=nil then begin

    Clear;

    result := nil;

    exit;

  end;

  FromVarUInt32(PByte(Source)); // ignore StoredElemSize to be Win32/64 compatible

  if (fValue=nil) or

     //((ElemSize<>sizeof(pointer)) and (StoredElemSize<>ElemSize)) or

     ((ElemType=nil) and (Source^<>#0) or

     ((ElemType<>nil) and (Source^=#0{<>PAnsiChar(ElemType)^}))) then begin

     // ignore ElemType^ to be cross-FPC/Delphi compatible

    result := nil; // invalid Source content

    exit;

  end;

  inc(Source);

  // retrieve dynamic array count

  n := FromVarUInt32(PByte(Source));

  SetCount(n);

  if n=0 then begin

    result := Source;

    exit;

  end;

  // retrieve security checksum

  Hash := pointer(Source);

  inc(Source,sizeof(cardinal));

  // retrieve dynamic array elements content

  P := fValue^;

  if ElemType=nil then

  if GetIsObjArray then

    raise ESynException.CreateUTF8('TDynArray.LoadFrom(%) is a T*ObjArray',

      [PShortString(@PTypeInfo(ArrayType).NameLen)^]) else begin

    // binary type was stored as once

    n := n*integer(ElemSize);

    MoveFast(Source^,P^,n);

    inc(Source,n);

  end else

  case PTypeKind(ElemType)^ of

    tkLString, tkWString {$ifdef HASVARUSTRING}, tkUString{$endif}

    {$ifdef FPC}, tkLStringOld{$endif}:

    for i := 1 to n do begin

      LenBytes := FromVarUInt32(PByte(Source));

      case PTypeKind(ElemType)^ of

      tkLString{$ifdef FPC},tkLStringOld{$endif}: begin

        SetString(PRawByteString(P)^,Source,LenBytes);

        {$ifdef HASCODEPAGE}

        { Delphi 2009+: set Code page for this AnsiString }

        if LenBytes<>0 then

          SetCodePage(PRawByteString(P)^,PWord(PtrUInt(ElemType)+

            PTypeInfo(ElemType)^.NameLen+2)^,false);

        {$endif}

      end;

      tkWString:

        SetString(PWideString(P)^,PWideChar(Source),LenBytes shr 1);

      {$ifdef HASVARUSTRING}

      tkUString:

        SetString(PString(P)^,PWideChar(Source),LenBytes shr 1);

      {$endif}

      end;

      inc(Source,LenBytes);

      inc(P,sizeof(PtrUInt));

    end;

    tkRecord{$ifdef FPC},tkObject{$endif}: begin

      infoNested := ElemType; // inlined GetTypeInfo()

      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

      infoNested := GetFPCAlignPtr(infoNested);

      {$else}

      inc(PtrUInt(infoNested),infoNested^.NameLen);

      {$endif}

      if infoNested^.ManagedCount=0 then begin

        {$ifndef LVCL}

        assert(infoNested^.recSize=ElemSize);

        {$endif}

        n := n*integer(ElemSize);

        MoveFast(Source^,P^,n);

        inc(Source,n);

      end else begin

        for i := 1 to n do begin

          Source := RecordLoad(P^,Source,ElemType);

          if Source=nil then

            break; // invalid content (e.g. wrong field type)

          inc(P,ElemSize);

        end;

      end;

    end;

    {$ifndef NOVARIANTS}

    tkVariant:

      for i := 0 to n-1 do begin

        Source := VariantLoad(PVariantArray(P)^[i],Source,@JSON_OPTIONS[true]);

        if Source=nil then

          break; // invalid/unhandled variant content

      end;

    {$endif}

    tkDynArray:

      for i := 1 to n do begin

        NestedArray.Init(ElemType,P^);

        Source := NestedArray.LoadFrom(Source);

        if Source=nil then

          break; // invalid content (e.g. wrong field type)

        inc(P,ElemSize);

      end;

  end;

  // check security checksum

  if (Source=nil) or (Hash32(@Hash[1],Source-PAnsiChar(@Hash[1]))<>Hash[0]) then

    result := nil else

    result := Source;

end;



function TDynArray.Find(const Elem; const aIndex: TIntegerDynArray;

      aCompare: TDynArraySortCompare): integer;

var n, L, cmp: integer;

    P: PAnsiChar;

begin

  n := Count;

  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 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 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): integer;

begin

  if aIndex<>nil then

    result := Find(Elem,aIndex^,aCompare) else

  if Assigned(aCompare) then

    result := Find(Elem,nil,aCompare) else

    result := Find(Elem);

end;



function TDynArray.FindAndFill(var Elem; aIndex: PIntegerDynArray=nil;

  aCompare: TDynArraySortCompare=nil): integer;

begin

  result := FindIndex(Elem,aIndex,aCompare);

  if result>=0 then // if found, fill Elem with the matching item

    ElemCopy(PAnsiChar(fValue^)[cardinal(result)*ElemSize],Elem);

end;



function TDynArray.FindAndDelete(const Elem; aIndex: PIntegerDynArray=nil;

  aCompare: TDynArraySortCompare=nil): integer;

begin

  result := FindIndex(Elem,aIndex,aCompare);

  if result>=0 then

    Delete(result);

end;



function TDynArray.FindAndUpdate(const Elem; aIndex: PIntegerDynArray=nil;

  aCompare: TDynArraySortCompare=nil): integer;

begin

  result := FindIndex(Elem,aIndex,aCompare);

  if result>=0 then // if found, fill Elem with the matching item

    ElemCopy(Elem,PAnsiChar(fValue^)[cardinal(result)*ElemSize]);

end;



function TDynArray.FindAndAddIfNotExisting(const Elem; aIndex: PIntegerDynArray=nil;

  aCompare: TDynArraySortCompare=nil): integer;

begin

  result := FindIndex(Elem,aIndex,aCompare);

  if result<0 then

    Add(Elem); // -1 will mark success

end;



function TDynArray.Find(const Elem): integer;

var n, L, cmp: integer;

    P: PAnsiChar;

begin

  n := Count;

  if (@fCompare<>nil) and (n>0) then begin

    dec(n);

    P := fValue^;

    if fSorted and (n>10) then begin

      // array is sorted -> use fast 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 -> use iterating search

      for result := 0 to n do

        if fCompare(P^,Elem)=0 then

          exit else

          inc(P,ElemSize);

  end;

  result := -1;

end;



function TDynArray.FastLocateSorted(const Elem; out Index: Integer): boolean;

var n, i, cmp: integer;

    P: PAnsiChar;

begin

  result := False;

  n := Count;

  if @fCompare<>nil then

    if n=0 then // a void array is always sorted

      Index := 0 else

    if fSorted then begin

      P := fValue^;

      Index := 0;

      dec(n);

      while Index<=n do begin

        i := (Index+n) shr 1;

        cmp := fCompare(P[cardinal(i)*ElemSize],Elem);

        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 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

    FastAddSorted(result,Elem);

  if wasAdded<>nil then

    wasAdded^ := toInsert;

end;



type

  // internal structure used to make QuickSort faster & with less stack usage

  TDynArrayQuickSort = {$ifndef UNICODE}object{$else}record{$endif}

    Compare: TDynArraySortCompare;

    Pivot: pointer;

    Index: PCardinalArray;

    ElemSize: cardinal;

    P: integer;

    Value: PAnsiChar;

    IP, JP: PAnsiChar;

    procedure QuickSort(L, R: PtrInt);

    procedure QuickSortIndexed(L, R: PtrInt);

  end;



procedure QuickSortIndexedPUTF8Char(Values: PPUtf8CharArray; Count: Integer;

  var SortedIndexes: TCardinalDynArray; CaseSensitive: boolean);

var QS: TDynArrayQuickSort;

    i: integer;

begin

  if CaseSensitive then

    QS.Compare := SortDynArrayPUTF8Char else

    QS.Compare := SortDynArrayPUTF8CharI;

  QS.Value := pointer(Values);

  QS.ElemSize := sizeof(PUTF8Char);

  SetLength(SortedIndexes,Count);

  dec(Count);

  for i := 0 to Count do

    SortedIndexes[i] := i;

  QS.Index := pointer(SortedIndexes);

  QS.QuickSortIndexed(0,Count);

end;



procedure TDynArrayQuickSort.QuickSort(L, R: PtrInt);

var I, J: integer;

    tmp: pointer;

begin

  if L<R then

  repeat

    I := L; J := R;

    P := (L + R) shr 1;

    repeat

      pivot := Value+cardinal(P)*ElemSize;

      IP := Value+cardinal(I)*ElemSize;

      JP := Value+cardinal(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

          if ElemSize=SizeOf(pointer) then begin

            // optimized version e.g. for TRawUTF8DynArray

            tmp := PPointer(IP)^;

            PPointer(IP)^ := PPointer(JP)^;

            PPointer(JP)^ := tmp;

          end else

            // 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 L < J then

      QuickSort(L, J);

    L := I;

  until I >= R;

end;



procedure TDynArrayQuickSort.QuickSortIndexed(L, R: PtrInt);

var I, J, 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 L < J then

      QuickSortIndexed(L, J);

    L := I;

  until I >= R;

end;



procedure TDynArray.Sort(aCompare: TDynArraySortCompare);

var QuickSort: TDynArrayQuickSort;

begin

  if @aCompare=nil then

    Quicksort.Compare := @fCompare else

    Quicksort.Compare := aCompare;

  if (@Quicksort.Compare<>nil) and (fValue<>nil) and (fValue^<>nil) then begin

    Quicksort.Value := fValue^;

    Quicksort.ElemSize := ElemSize;

    Quicksort.QuickSort(0,Count-1);

    fSorted := true;

  end;

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 := Count;

    if length(aIndex)<n then begin

      SetLength(aIndex,n);

      FillIncreasing(pointer(aIndex),0,n);

    end;

    Quicksort.Value := fValue^;

    Quicksort.ElemSize := ElemSize;

    Quicksort.Index := pointer(aIndex);

    Quicksort.QuickSortIndexed(0,n-1);

  end;

end;



function TDynArray.ElemEquals(const A,B): boolean;

begin

  if @fCompare<>nil then

    result := fCompare(A,B)=0 else

    if ElemType=nil then

      case ElemSize of // optimized versions for arrays of common types

        1: result := byte(A)=byte(B);

        2: result := word(A)=word(B);

        4: result := cardinal(A)=cardinal(B);

        8: result := Int64(A)=Int64(B);

      else result := CompareMem(@A,@B,ElemSize); // generic comparison

      end else

    case PTypeKind(ElemType)^ of

    tkRecord{$ifdef FPC},tkObject{$endif}:

      result := RecordEquals(A,B,ElemType);

    tkLString{$ifdef FPC},tkLStringOld{$endif}:

      result := AnsiString(A)=AnsiString(B);

    tkWString:

      result := WideString(A)=WideString(B);

    {$ifdef HASVARUSTRING}

    tkUString:

      result := UnicodeString(A)=UnicodeString(B);

    {$endif}

    tkInterface:

      result := pointer(A)=pointer(B);

    {$ifndef NOVARIANTS}

    tkVariant:

      result := Variant(A)=Variant(B);

    {$endif}

    else result := false;

    end;

end;



{$ifndef DELPHI5OROLDER} // do not know why Delphi 5 compiler does not like it

function TDynArray.Equals(const B: TDynArray): boolean;

var i, n: integer;

    P1,P2: PAnsiChar;

    A1: PPointerArray absolute P1;

    A2: PPointerArray absolute P2;

begin

  result := false;

  if ArrayType<>B.ArrayType then

    exit; // array types shall match

  n := Count;

  if n<>B.Count then

    exit;

  P1 := fValue^;

  P2 := B.fValue^;

  if @fCompare<>nil then // if a customized comparison is available, use it

    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

  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;

  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}

  tkInterface:

    if not CompareMem(P1,P2,SizeOf(pointer)*cardinal(n)) then

      exit;

  {$ifndef NOVARIANTS}

  tkVariant:

    for i := 0 to n-1 do

      if PVariantArray(P1)^[i]<>PVariantArray(P2)^[i] then

        exit;

  {$endif}

  else exit;

  end;

  result := true;

end;



procedure TDynArray.Copy(const Source: TDynArray);

var n: Cardinal;

begin

  if (fValue=nil) or (ArrayType<>Source.ArrayType) then

    exit;

  SetCapacity(Source.Capacity);

  n := Source.Count;

  if n<>0 then

    if ElemType=nil then

      MoveFast(Source.fValue^^,fValue^^,n*ElemSize) else

      CopyArray(fValue^,Source.fValue^,ElemType,n);

end;



procedure TDynArray.CopyFrom(const Source; MaxElem: integer);

var SourceDynArray: TDynArray;

begin

  SourceDynArray.Init(fTypeInfo,pointer(@Source)^);

  SourceDynArray.fCountP := @MaxElem; // would set Count=0 at Init()

  Copy(SourceDynArray);

end;

{$endif DELPHI5OROLDER}



function TDynArray.IndexOf(const Elem): integer;

var P: pointer;

    max: integer;

begin

  if fValue=nil then begin

    result := -1;

    exit; // avoid GPF if void

  end;

  max := Count-1;

  P := fValue^;

  if @Elem<>nil then

  if ElemType=nil then

  case ElemSize of

    // optimized versions for arrays of byte,word,integer,Int64,Currency,Double

    1: for result := 0 to max do

         if PByteArray(P)^[result]=byte(Elem) then exit;

    2: for result := 0 to max do

         if PWordArray(P)^[result]=word(Elem) then exit;

    4: for result := 0 to max do

         if PIntegerArray(P)^[result]=integer(Elem) then exit;

    8: for result := 0 to max do // Int64,Currency,Double

         if PInt64Array(P)^[result]=Int64(Elem) then exit;

  else // generic binary comparison (fast with our overloaded CompareMem)

    for result := 0 to max do

      if CompareMem(P,@Elem,ElemSize) then

        exit else

        inc(PtrUInt(P),ElemSize);

  end else

  case PTypeKind(ElemType)^ of

  tkLString{$ifdef FPC},tkLStringOld{$endif}:

    for result := 0 to max do

      if AnsiString(PPtrIntArray(P)^[result])=AnsiString(Elem) then exit;

  tkWString:

    for result := 0 to max do

      if WideString(PPtrIntArray(P)^[result])=WideString(Elem) then exit;

  {$ifdef HASVARUSTRING}

  tkUString:

    for result := 0 to max do

      if UnicodeString(PPtrIntArray(P)^[result])=UnicodeString(Elem) then exit;

  {$endif}

  {$ifndef NOVARIANTS}

  tkVariant:

    for result := 0 to max do

      if PVariantArray(P)^[result]=variant(Elem) 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(PtrUInt(P),ElemSize);

  tkInterface:

    for result := 0 to max do

      if PPtrIntArray(P)^[result]=PtrInt(Elem) then exit;

  end;

  result := -1;

end;



procedure TDynArray.Init(aTypeInfo: pointer; var aValue; aCountPointer: PInteger=nil);

begin

  fValue := @aValue;

  fTypeInfo := aTypeInfo;

  if PTypeKind(aTypeInfo)^<>tkDynArray then // inlined GetTypeInfo()

    raise ESynException.CreateUTF8('TDynArray.Init(%): not a dynamic array',

      [PShortString(@PTypeInfo(aTypeInfo)^.NameLen)^]);

  {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

  aTypeInfo := GetFPCAlignPtr(aTypeInfo);

  {$else}

  inc(PtrUInt(aTypeInfo),PTypeInfo(aTypeInfo)^.NameLen);

  {$endif}

  fElemSize := PTypeInfo(aTypeInfo)^.elSize {$ifdef FPC}and $7FFFFFFF{$endif};

  fElemType := PTypeInfo(aTypeInfo)^.elType;

  if fElemType<>nil then begin

    {$ifndef HASDIRECTTYPEINFO}

    // FPC compatibility: if you have a GPF here at startup, your 3.1 trunk

    // revision seems older than June 2016

    // -> enable HASDIRECTTYPEINFO conditional below $ifdef VER3_1 in Synopse.inc

    // or in your project's options

    fElemType := PPointer(fElemType)^;

    {$endif}

    {$ifdef FPC}

    if not (PTypeKind(fElemType)^ in tkManagedTypes) then

      fElemType := nil; // as with Delphi

    {$endif}

  end;

  fCountP := aCountPointer;

  if fCountP<>nil then

    fCountP^ := 0;

  fCompare := nil;

  fKnownSize := 0;

  fSorted := false;

  fKnownType := djNone;

  fIsObjArray := oaUnknown;

end;                



procedure TDynArray.InitSpecific(aTypeInfo: pointer; var aValue; aKind: TDynArrayKind;

  aCountPointer: PInteger=nil; aCaseInsensitive: boolean=false);

var Comp: TDynArraySortCompare;

begin

  Init(aTypeInfo,aValue,aCountPointer);

  Comp := DYNARRAY_SORTFIRSTFIELD[aCaseInsensitive,aKind];

  if @Comp=nil then

    raise ESynException.CreateUTF8('TDynArray.InitSpecific(%) wrong aKind=%',

      [PShortString(@PTypeInfo(aTypeInfo)^.NameLen)^,ord(aKind)]);

  fCompare := Comp;

  fKnownType := aKind;

  fKnownSize := KNOWNTYPE_SIZE[aKind];

end;



procedure TDynArray.UseExternalCount(var aCountPointer: Integer);

begin

  fCountP := @aCountPointer;

end;



procedure TDynArray.Void;

begin

  fValue := nil;

end;



function TDynArray.IsVoid: boolean;

begin

  result := fValue=nil;

end;



procedure _DynArrayClear(var a: Pointer; typeInfo: Pointer);

{$ifdef FPC}

  [external name 'FPC_DYNARRAY_CLEAR'];

{$else}

asm

{$ifdef CPU64}

  .NOFRAME

{$endif}

  jmp System.@DynArrayClear

end;

{$endif}



procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: PtrUInt);

{$ifdef FPC}

  [external name 'FPC_FINALIZE_ARRAY'];

{$else}

asm

{$ifdef CPU64}

  .NOFRAME

{$endif}

  jmp System.@FinalizeArray

end;

{$endif}



function TDynArray.GetIsObjArray: boolean;

begin

  if fIsObjArray=oaUnknown then

    if (fElemSize=sizeof(pointer)) and (fElemType=nil) and

       Assigned(DynArrayIsObjArray) and DynArrayIsObjArray(fTypeInfo) then

      fIsObjArray := oaTrue else

      fIsObjArray := oaFalse;

  result := fIsObjArray=oaTrue;

end;



procedure TDynArray.SetIsObjArray(aValue: boolean);

begin

  if aValue then

    fIsObjArray := oaTrue else

    fIsObjArray := oaFalse; 

end;



procedure TDynArray.InternalSetLength(NewLength: PtrUInt);

var p: PDynArrayRec;

    pa: PAnsiChar absolute p;

    OldLength, NeededSize, minLength: PtrUInt;

    pp: pointer;

    i: integer;

begin // this method is faster than default System.DynArraySetLength() function

  // check that new array length is not just a hidden finalize

  if NewLength=0 then begin

    {$ifndef NOVARIANTS} // faster clear of custom variant uniformous array

    if ArrayType=TypeInfo(TVariantDynArray) then begin

      VariantDynArrayClear(TVariantDynArray(fValue^));

      exit;

    end;

    {$endif}

    if GetIsObjArray then

      for i := 0 to Count-1 do

        PObjectArray(fValue^)^[i].Free;

    _DynArrayClear(fValue^,ArrayType);

    exit;

  end;

  // retrieve old length

  p := fValue^;

  if p<>nil then begin

    dec(PtrUInt(p),Sizeof(TDynArrayRec)); // p^ = start of heap object

    OldLength := p^.length;

  end else

    OldLength := 0;

  // 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',

      [PShortString(@PTypeInfo(ArrayType).NameLen)^,NewLength]);

  {$endif}

  // if not shared (refCnt=1), resize; if shared, create copy (not thread safe)

  if (p=nil) or (p^.refCnt=1) then begin

    if NewLength<OldLength then

      if ElemType<>nil then

        _FinalizeArray(pa+NeededSize,ElemType,OldLength-NewLength) else

        if GetIsObjArray then

          for i := NewLength to OldLength-1 do

            PObjectArray(fValue^)^[i].Free;

    ReallocMem(p,neededSize);

  end else begin

    InterlockedDecrement(PInteger(@p^.refCnt)^); // FPC has refCnt: PtrInt

    GetMem(p,neededSize);

    minLength := oldLength;

    if minLength>newLength then

      minLength := newLength;

    if ElemType<>nil then begin

      pp := pa+Sizeof(TDynArrayRec);

      FillcharFast(pp^,minLength*elemSize,0);

      CopyArray(pp,fValue^,ElemType,minLength)

    end else

      MoveFast(fValue^,pa[Sizeof(TDynArrayRec)],minLength*elemSize);

  end;

  // set refCnt=1 and new length to the heap memory structure

  with p^ do begin

    refCnt := 1;

    {$ifdef FPC}

    high := newLength-1;

    {$else}

    length := newLength;

    {$endif}

  end;

  inc(PtrUInt(p),Sizeof(p^));

  // reset new allocated elements content to zero

  if NewLength>OldLength then begin

    OldLength := OldLength*elemSize;

    FillcharFast(pa[OldLength],neededSize-OldLength-Sizeof(TDynArrayRec),0);

  end;

  fValue^ := p;

end;



procedure TDynArray.SetCount(aCount: integer);

const MINIMUM_SIZE = 64;

var capa, delta: integer;

begin

  fSorted := false;

  if fValue=nil then

    exit; // avoid GPF if void

  if fCountP<>nil then begin

    delta := aCount-fCountP^;

    if delta=0 then

      exit;

    fCountP^ := aCount;

    if PtrInt(fValue^)=0 then begin

      // no capa yet

      if (delta>0) and (aCount<MINIMUM_SIZE) then

        aCount := MINIMUM_SIZE; // reserve some minimal space for Add()

    end else begin

      {$ifdef FPC}

      capa := PDynArrayRec(PtrUInt(fValue^)-SizeOf(TDynArrayRec))^.length;

      {$else}

      capa := PInteger(PtrInt(fValue^)-sizeof(PtrInt))^;

      {$endif}

      if delta>0 then begin

        // size-up -> grow by chunks

        if capa>=fCountP^ then

          exit; // no need to grow

        inc(capa,capa shr 2);

        if capa<fCountP^ then

          aCount := fCountP^ else

          aCount := capa;

      end else

      if aCount>0 then // aCount=0 should release memory (e.g. TDynArray.Clear)

        // size-down -> only if worth it (for faster Delete)

        if (capa<=MINIMUM_SIZE) or (capa-aCount<capa shr 3) then

          exit;

    end;

  end;

  // no external Count, array size-down or array up-grow -> realloc

  InternalSetLength(aCount);

end;



function TDynArray.GetCapacity: integer;

begin // capacity := length(DynArray)

  if (fValue<>nil) and (PtrInt(fValue^)<>0) then

    result := PDynArrayRec(PtrUInt(fValue^)-SizeOf(TDynArrayRec))^.length else

    result := 0;

end;



procedure TDynArray.SetCapacity(aCapacity: integer);

begin

  if fValue=nil then

    exit; // avoid GPF if void

  if fCountP<>nil then

    if fCountP^>aCapacity then

      fCountP^ := aCapacity;

  InternalSetLength(aCapacity);

end;



procedure TDynArray.SetCompare(const aCompare: TDynArraySortCompare);

begin

  if @aCompare<>@fCompare then begin

    @fCompare := @aCompare;

    fSorted := false;

  end;

end;



procedure TDynArray.Slice(var Dest; aCount: Cardinal; aFirstIndex: cardinal=0);

var n: Cardinal;

    D: PPointer;

    P: PAnsiChar;

begin

  if fValue=nil then

    exit; // avoid GPF if void

  n := Count;

  if aFirstIndex>=n then

    aCount := 0 else

  if aCount>=n-aFirstIndex then

    aCount := n-aFirstIndex;

  DynArray(ArrayType,Dest).InternalSetLength(aCount);

  D := @Dest;

  if aCount>0 then begin

    P := PAnsiChar(fValue^)+aFirstIndex*ElemSize;

    if ElemType=nil then

      MoveFast(P^,D^^,aCount*ElemSize) else

      CopyArray(D^,P,ElemType,aCount);

  end;

end;



procedure TDynArray.AddArray(const DynArrayVar; aStartIndex,aCount: integer);

var DynArrayCount, n: integer;

    PS,PD: pointer;

begin

  if fValue=nil then

    exit; // avoid GPF if void

  DynArrayCount := DynArrayLength(pointer(DynArrayVar));

  if aStartIndex>=DynArrayCount then

    exit; // nothing to copy

  if (aCount<0) or (cardinal(aStartIndex+aCount)>cardinal(DynArrayCount)) then

    aCount := DynArrayCount-aStartIndex;

  if aCount<=0 then

    exit;

  n := Count;

  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;



{$ifndef DELPHI5OROLDER} // don't know why Delphi 5 does not like this signature

procedure TDynArray.AddDynArray(const aSource: TDynArray; aStartIndex,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;

{$endif DELPHI5OROLDER}



procedure TDynArray.ElemClear(var Elem);

begin

  if ElemType<>nil then

    case PTypeKind(ElemType)^ of // release reference counted

      tkLString{$ifdef FPC},tkLStringOld{$endif}:

        RawByteString(Elem) := '';

      tkWString:

        WideString(Elem) := '';

      tkInterface:

        IUnknown(Elem) := nil;

      {$ifdef HASVARUSTRING}

      tkUString:

        UnicodeString(Elem) := '';

      {$endif}

      tkRecord{$ifdef FPC},tkObject{$endif}:

        RecordClear(Elem,ElemType);

      tkDynArray:

        _DynArrayClear(pointer(Elem),ElemType);

      {$ifndef NOVARIANTS}

      tkVariant:

        VarClear(Variant(Elem));

      {$endif}

      else exit;

    end;

  FillcharFast(Elem,ElemSize,0); // always fill with zero binary content

end;



procedure TDynArray.ElemCopy(const A; var B);

begin

  if ElemType=nil then begin

    MoveFast(A,B,ElemSize);

    exit;

  end else begin

    case PTypeKind(ElemType)^ of

      tkLString{$ifdef FPC},tkLStringOld{$endif}: begin

        RawByteString(B) := RawByteString(A);

        exit;

      end;

      tkWString: begin

        WideString(B) := WideString(A);

        exit;

      end;

      tkInterface: begin

        IUnknown(B) := IUnknown(A);

        exit;

      end;

      {$ifdef HASVARUSTRING}

      tkUString: begin

        UnicodeString(B) := UnicodeString(A);

        exit;

      end;

      {$endif}

      tkRecord{$ifdef FPC},tkObject{$endif}: begin

        RecordCopy(B,A,ElemType);

        exit;

      end;

      {$ifndef NOVARIANTS}

      tkVariant: begin

        variant(B) := variant(A);

        exit;

      end;

      {$endif}

      else begin

        {$ifdef FPC}

        RecordClear(B,ElemType); // inlined CopyArray()

        MoveFast(A,B,RTTIManagedSize(ElemType));

        RecordAddRef(B,ElemType);

        {$else}

        CopyArray(@B,@A,ElemType,1);

        {$endif}

        exit;

      end;

    end;

  end;

end;



function TDynArray.ElemLoad(Source: PAnsiChar): RawByteString;

begin

  if (Source<>nil) and (ElemType=nil) then

    SetString(result,Source,ElemSize) else begin

    SetString(result,nil,ElemSize);

    FillcharFast(pointer(result)^,ElemSize,0);

    ElemLoad(Source,pointer(result)^);

  end;

end;



procedure TDynArray.ElemLoad(Source: PAnsiChar; var Elem);

begin

  if Source=nil then

    exit; // avoid GPF

  if ElemType=nil then

    MoveFast(Source^,Elem,ElemSize) else

    case PTypeKind(ElemType)^ of

    tkLString{$ifdef FPC},tkLStringOld{$endif}: begin

      SetString(RawByteString(Elem),Source+4,PInteger(Source)^);

      {$ifdef HASCODEPAGE}

      { Delphi 2009+: set Code page for this AnsiString }

      if PPtrUInt(@Elem)^<>0 then

        SetCodePage(RawByteString(Elem),PWord(PtrUInt(ElemType)+

          PTypeInfo(ElemType)^.NameLen+2)^,false);

      {$endif}

    end;

    tkWString: // WideString internal length is in bytes

      SetString(WideString(Elem),PWideChar(Source+4),PInteger(Source)^ shr 1);

    {$ifdef HASVARUSTRING}

    tkUString:

      SetString(UnicodeString(Elem),PWideChar(Source+4),PInteger(Source)^);

    {$endif}

    {$ifndef NOVARIANTS}

    tkVariant:

      VariantLoad(variant(Elem),Source,@JSON_OPTIONS[true]);

    {$endif}

    tkRecord{$ifdef FPC},tkObject{$endif}:

      RecordLoad(Elem,Source,ElemType);

    end;

end;



procedure TDynArray.ElemLoadClear(var ElemLoaded: RawByteString);

begin

  if (ElemType<>nil) and (length(ElemLoaded)=integer(ElemSize)) then

  case PTypeKind(ElemType)^ of

    tkLString{$ifdef FPC},tkLStringOld{$endif}:

      PRawByteString(pointer(ElemLoaded))^ := '';

    tkWString:

      PWideString(pointer(ElemLoaded))^ := '';

    {$ifdef HASVARUSTRING}

    tkUString:

      PUnicodeString(pointer(ElemLoaded))^ := '';

    {$endif}

    {$ifndef NOVARIANTS}

    tkVariant:

      VarClear(PVariant(pointer(ElemLoaded))^);

    {$endif}

    tkRecord{$ifdef FPC},tkObject{$endif}:

      RecordClear(pointer(ElemLoaded)^,ElemType);

  end;

  ElemLoaded := '';

end;



function TDynArray.ElemSave(const Elem): RawByteString;

{$ifdef FPC}

var LenBytes: integer;

{$endif}

begin

  if ElemType=nil then

    SetString(result,PAnsiChar(@Elem),ElemSize) else

    case PTypeKind(ElemType)^ of

      {$ifdef FPC}

      tkLString, tkWString, tkLStringOld:

        if PPtrInt(@Elem)^=0 then

          SetString(result,PAnsiChar(@Elem),4) else begin

          LenBytes := PStrRec(Pointer(PPtrInt(@Elem)^-STRRECSIZE))^.length;

          SetString(result,PAnsiChar(PPtrInt(@Elem)^-sizeof(integer)),LenBytes+sizeof(integer));

          PInteger(result)^ := LenBytes;

        end;

      {$ifdef HASVARUSTRING}

      tkUString:

        if PPtrInt(@Elem)^=0 then

          SetString(result,PAnsiChar(@Elem),4) else begin

          LenBytes := PStrRec(Pointer(PPtrInt(@Elem)^-STRRECSIZE))^.length;

          SetString(result,PAnsiChar(PPtrInt(@Elem)^-sizeof(integer)),LenBytes*2+sizeof(integer));

          PInteger(result)^ := LenBytes;

        end;

      {$endif}

      {$else FPC}

      tkLString, tkWString: // WideString internal length is in bytes

        if PPtrInt(@Elem)^=0 then

          SetString(result,PAnsiChar(@Elem),4) else

          SetString(result,PAnsiChar(PPtrInt(@Elem)^-sizeof(integer)),

            PInteger(PPtrInt(@Elem)^-sizeof(integer))^+sizeof(integer));

      {$ifdef HASVARUSTRING}

      tkUString:

        if PPtrInt(@Elem)^=0 then

          SetString(result,PAnsiChar(@Elem),4) else

          SetString(result,PAnsiChar(PPtrInt(@Elem)^-sizeof(integer)),

            PInteger(PPtrInt(@Elem)^-sizeof(integer))^*2+sizeof(integer));

      {$endif}

      {$endif FPC}

      {$ifndef NOVARIANTS}

      tkVariant:

        result := VariantSave(variant(Elem));

      {$endif}

      tkRecord{$ifdef FPC},tkObject{$endif}:

        result := RecordSave(Elem,ElemType);

      else result := '';

    end;

end;



function TDynArray.ElemLoadFind(Source: PAnsiChar): integer;

var tmp: RawByteString;

begin

  tmp := ElemLoad(Source);

  if tmp='' then

    result := -1 else

    try

      if @fCompare=nil then

        result := IndexOf(pointer(tmp)^) else

        result := Find(pointer(tmp)^);

    finally

      ElemLoadClear(tmp);

    end;

end;



function DynArray(aTypeInfo: pointer; var aValue; aCountPointer: PInteger=nil): TDynArray;

begin

  result.Init(aTypeInfo,aValue,aCountPointer);

end;





{ TDynArrayHashed }



const

  // marks a void entry in the hash table

  // -> code below will replace all hash value from 0 (HASH_VOID)

  // to 1 (HASH_ONVOIDCOLISION)

  HASH_VOID = 0;

  // marks a hash colision with a void entry in the hash table

  HASH_ONVOIDCOLISION = 1;



{$ifdef UNDIRECTDYNARRAY}



function TDynArrayHashed.Count: Integer;

begin

  result := InternalDynArray.Count;

end;



procedure TDynArrayHashed.SetCount(aCount: Integer);

begin

  InternalDynArray.Count := aCount;

end;



function TDynArrayHashed.GetCapacity: Integer;

begin

  result := InternalDynArray.Capacity;

end;



procedure TDynArrayHashed.SetCapacity(aCapacity: Integer);

begin

  InternalDynArray.SetCapacity(aCapacity);

end;



function TDynArrayHashed.fValue: PPointer;

begin

  result := InternalDynArray.fValue;

end;



function TDynArrayHashed.ElemSize: PtrUInt;

begin

  result := InternalDynArray.ElemSize;

end;



function TDynArrayHashed.ElemType: Pointer;

begin

  result := InternalDynArray.ElemType;

end;



procedure TDynArrayHashed.ElemCopy(const A; var B);

begin

  InternalDynArray.ElemCopy(A,B);

end;



function TDynArrayHashed.KnownType: TDynArrayKind;

begin

  result := InternalDynArray.KnownType;

end;



procedure TDynArrayHashed.Clear;

begin

  InternalDynArray.Clear;

end;



function TDynArrayHashed.Add(const Elem): integer;

begin

  result := InternalDynArray.Add(Elem);

end;



procedure TDynArrayHashed.Delete(aIndex: Integer);

begin

  InternalDynArray.Delete(aIndex);

end;



function TDynArrayHashed.SaveTo: RawByteString;

begin

  result := InternalDynArray.SaveTo;

end;



function TDynArrayHashed.LoadFrom(Source: PAnsiChar): PAnsiChar;

begin

  result := InternalDynArray.LoadFrom(Source);

end;



function TDynArrayHashed.SaveTo(Dest: PAnsiChar): PAnsiChar;

begin

  result := InternalDynArray.SaveTo(Dest);

end;



function TDynArrayHashed.SaveToJSON(EnumSetsAsText: boolean=false): RawUTF8;

begin

  result := InternalDynArray.SaveToJSON(EnumSetsAsText);

end;



function TDynArrayHashed.LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char=nil): PUTF8Char;

begin

  result := InternalDynArray.LoadFromJSON(P,aEndOfObject);

end;



function TDynArrayHashed.SaveToLength: integer;

begin

  result := InternalDynArray.SaveToLength;

end;



{$endif UNDIRECTDYNARRAY}



function TDynArrayHashed.Scan(const Elem): integer;

var P: PAnsiChar;

begin

  P := fValue^; // Count<fHashCountTrigger -> O(n) is faster than O(1)

  if Assigned(fEventCompare) then begin

    for result := 0 to Count-1 do

      if fEventCompare(P^,Elem)=0 then

        exit else

        inc(P,ElemSize);

  end else

    for result := 0 to Count-1 do

      if {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare(P^,Elem)=0 then

        exit else

        inc(P,ElemSize);

  result := -1;

end;



function TDynArrayHashed.FindHashed(const Elem): integer;

begin

  if (fHashs<>nil) and Assigned(fHashElement) then begin

    result := HashFind(fHashElement(Elem,fHasher),Elem);

    if result<0 then

      result := -1; // for coherency with most methods

  end else begin

    result := Scan(Elem); // Count<fHashCountTrigger

    if (result>=0) and (fHashCountTrigger>0) then begin

      inc(fHashFindCount);

      if fHashFindCount>=fHashCountTrigger then begin

        fHashCountTrigger := 0; // FindHashed() should use O(1) hash

        ReHash;

      end;

    end;

  end;

end;



procedure TDynArrayHashed.HashAdd(const Elem; aHashCode: Cardinal; var result: integer);

var n,cap: integer;

begin

  n := Count;

  SetCount(n+1); // reserve space for a void element in array

  cap := Capacity;

  if cap*2-cap shr 3>=fHashsCount then begin

    // fHashs[] is too small -> recreate

    ReHash;

    result := HashFind(aHashCode,Elem); // fHashs[] has changed -> recompute

    assert(result<0);

  end;

  with fHashs[-result-1] do begin // HashFind returned negative index in fHashs[]

    Hash := aHashCode;

    Index := n;

  end;

  result := n;

end;



function TDynArrayHashed.FindHashedForAdding(const Elem; out wasAdded: boolean;

  aHashCode: cardinal): integer;

var n: integer;

begin

  n := Count;

  if n<fHashCountTrigger then begin

    result := Scan(Elem);

    if result<0 then begin

      SetCount(n+1); // like HashAdd(): reserve space for added item

      result := n;

      wasadded := true;

    end else

      wasadded := false;

    exit;

  end;

  if fHashs=nil then

    ReHash; // compute hash of all previously added fHashCountTrigger items

  if aHashCode=0 then

    if Assigned(fHashElement) then

      aHashCode := fHashElement(Elem,fHasher);

  if aHashCode=HASH_VOID then

    aHashCode := HASH_ONVOIDCOLISION; // as in HashFind() -> for HashAdd() below

  result := HashFind(aHashCode,Elem);

  if result>=0 then

    // found matching existing item

    wasAdded := false else begin

    // create a void element

    HashAdd(Elem,aHashCode,result);

    wasAdded := true;

  end;

end;



function TDynArrayHashed.AddAndMakeUniqueName(aName: RawUTF8): pointer;

var ndx,j: integer;

    added: boolean;

    aName_: RawUTF8;

begin

  if aName='' then

    aName := '_';

  ndx := FindHashedForAdding(aName,added);

  if not added then begin // force unique column name

    aName_ := aName+'_';

    j := 1;

    repeat

      aName := aName_+UInt32ToUTF8(j);

      ndx := FindHashedForAdding(aName,added);

      inc(j);

    until added;

  end;

  assert(ndx=Count-1);

  result := PAnsiChar(fValue^)+cardinal(ndx)*ElemSize;

  PRawUTF8(result)^ := aName; // store unique name at 1st elem position

end;



function TDynArrayHashed.AddUniqueName(const aName: RawUTF8;

  const ExceptionMsg: RawUTF8; const ExceptionArgs: array of const): pointer;

var ndx: integer;

    added: boolean;

begin

  ndx := FindHashedForAdding(aName,added);

  if added then begin

    assert(ndx=Count-1);

    result := PAnsiChar(fValue^)+cardinal(ndx)*ElemSize;

    PRawUTF8(result)^ := aName; // store unique name at 1st elem position

  end else

    if ExceptionMsg='' then

      raise ESynException.CreateUTF8('Duplicated "%" name',[aName]) else

      raise ESynException.CreateUTF8(ExceptionMsg,ExceptionArgs);

end;



function TDynArrayHashed.FindHashedAndFill(var ElemToFill): integer;

begin

  if fHashs=nil then // Count<fHashCountTrigger

    result := Scan(ElemToFill) else

    if Assigned(fHashElement) then begin

      result := HashFind(fHashElement(ElemToFill,fHasher),ElemToFill);

      if result<0 then

        result := -1;

    end else

      result := -1;

  if result>=0 then

    ElemCopy((PAnsiChar(fValue^)+cardinal(result)*ElemSize)^,ElemToFill);

end;



function TDynArrayHashed.FindHashedAndUpdate(const Elem; AddIfNotExisting: boolean): integer;

var aHashCode: cardinal;

label h;

begin

  if fHashs=nil then begin // Count<fHashCountTrigger

    result := Scan(Elem);

    if result<0 then

      if AddIfNotExisting then

        if Count<fHashCountTrigger then

          result := Add(Elem) else begin

          ReHash; // compute hash of all previously added fHashCountTrigger items

          goto h;

        end else

        result := -1 else

      ElemCopy(Elem,(PAnsiChar(fValue^)+cardinal(result)*ElemSize)^); // update

    exit;

  end;

h:if Assigned(fHashElement) then begin

    aHashCode := fHashElement(Elem,fHasher);

    if aHashCode=HASH_VOID then

      aHashCode := HASH_ONVOIDCOLISION; // as in HashFind() -> for HashAdd() below

    result := HashFind(aHashCode,Elem);

    if result<0 then

      if AddIfNotExisting then begin

        // not existing -> add as new element

        HashAdd(Elem,aHashCode,result); // ReHash only if necessary

        ElemCopy(Elem,(PAnsiChar(fValue^)+cardinal(result)*ElemSize)^);

      end else

        result := -1 else begin

      // copy from Elem into dynamic array found entry = Update

      ElemCopy(Elem,(PAnsiChar(fValue^)+cardinal(result)*ElemSize)^);

      ReHash; // whole hash table should be re-created for next search

    end;

  end else

    result := -1;

end;



function TDynArrayHashed.FindHashedAndDelete(const Elem): integer;

begin

  if fHashs=nil then begin // Count<fHashCountTrigger

    result := Scan(Elem);

    if result>=0 then

      Delete(result);

  end else

  if Assigned(fHashElement) then begin

    result := HashFind(fHashElement(Elem,fHasher),Elem);

    if result<0 then

      result := -1 else begin

      Delete(result);

      ReHash; // whole hash table should be re-created for next search

    end;

  end else

    result := -1;

end;



function HashAnsiString(const Elem; Hasher: THasher): cardinal;

begin

  if PtrUInt(Elem)<>0 then

    result := Hasher(0,Pointer(PtrUInt(Elem)),

      {$ifdef FPC}PStrRec(Pointer(PtrUInt(Elem)-STRRECSIZE))^.length

      {$else}PInteger(PtrUInt(Elem)-sizeof(integer))^{$endif}) else

    result := HASH_ONVOIDCOLISION;

end;



function HashAnsiStringI(const Elem; Hasher: THasher): cardinal;

var tmp: array[byte] of AnsiChar; // avoid slow heap allocation

begin

  if PtrUInt(Elem)=0 then

    result := HASH_ONVOIDCOLISION else

    result := Hasher(0,tmp,UpperCopy255Buf(tmp,pointer(Elem),

      {$ifdef FPC}PStrRec(Pointer(PtrUInt(Elem)-STRRECSIZE))^.length

      {$else}PInteger(PtrUInt(Elem)-sizeof(integer))^{$endif})-tmp);

end;



{$ifdef UNICODE}



function HashUnicodeString(const Elem; Hasher: THasher): cardinal;

begin

  if PtrUInt(Elem)=0 then

    result := HASH_ONVOIDCOLISION else

    result := Hasher(0,Pointer(Elem),length(UnicodeString(Elem))*2);

end;



function HashUnicodeStringI(const Elem; Hasher: THasher): cardinal;

var tmp: array[byte] of AnsiChar; // avoid slow heap allocation

begin

  if PtrUInt(Elem)=0 then

    result := HASH_ONVOIDCOLISION else

    result := Hasher(0,tmp,UpperCopy255W(tmp,Pointer(Elem),length(UnicodeString(Elem)))-tmp);

end;



{$endif UNICODE}



function HashSynUnicode(const Elem; Hasher: THasher): cardinal;

begin

  if PtrUInt(Elem)=0 then

    result := HASH_ONVOIDCOLISION else

    result := Hasher(0,Pointer(Elem),length(SynUnicode(Elem))*2);

end;



function HashSynUnicodeI(const Elem; Hasher: THasher): cardinal;

var tmp: array[byte] of AnsiChar; // avoid slow heap allocation

begin

  if PtrUInt(Elem)=0 then

    result := HASH_ONVOIDCOLISION else

    result := Hasher(0,tmp,UpperCopy255W(tmp,SynUnicode(Elem))-tmp);

end;



function HashWideString(const Elem; Hasher: THasher): cardinal;

begin // WideString internal size is in bytes, not WideChar

  if PtrUInt(Elem)=0 then

    result := HASH_ONVOIDCOLISION else

    result := Hasher(0,Pointer(Elem),Length(WideString(Elem))*2);

end;



function HashWideStringI(const Elem; Hasher: THasher): cardinal;

var tmp: array[byte] of AnsiChar; // avoid slow heap allocation

begin

  if PtrUInt(Elem)=0 then

    result := HASH_ONVOIDCOLISION else

    result := Hasher(0,tmp,UpperCopy255W(tmp,pointer(Elem),Length(WideString(Elem)))-tmp);

end;



function HashPtrUInt(const Elem; Hasher: THasher): cardinal;

begin

  {$ifdef CPU64}

  result := Hasher(0,@Elem,sizeof(PtrUInt));

  {$else}

  result := (PtrUInt(Elem) shr 4)+1; // naive but optimal for TDynArrayHashed

  {$endif}

end;



function HashPointer(const Elem; Hasher: THasher): cardinal;

begin

  result := Hasher(0,@Elem,sizeof(pointer));

end;



function HashByte(const Elem; Hasher: THasher): cardinal;

begin

  result := Byte(Elem);

end;



function HashWord(const Elem; Hasher: THasher): cardinal;

begin

  result := Word(Elem);

end;



function HashInteger(const Elem; Hasher: THasher): cardinal;

begin

  result := Integer(Elem);

end;



function HashCardinal(const Elem; Hasher: THasher): cardinal;

begin

  result := Cardinal(Elem);

end;



function HashInt64(const Elem; Hasher: THasher): cardinal;

begin

  result := Hasher(0,@Elem,sizeof(Int64)); // better than Int64Rec.(Lo xor Hi)

end;



{$ifndef NOVARIANTS}



function HashVariant(const Elem; Hasher: THasher): cardinal;

var U: RawUTF8;

    wasString: boolean;

begin

  VariantToUTF8(variant(Elem),U,wasString);

  if PtrUInt(U)=0 then

    result := HASH_ONVOIDCOLISION else

    result := Hasher(0,Pointer(PtrUInt(U)),

      {$ifdef FPC}PStrRec(Pointer(PtrUInt(U)-STRRECSIZE))^.length

      {$else}PInteger(PtrUInt(U)-sizeof(integer))^{$endif});

end;



function HashVariantI(const Elem; Hasher: THasher): cardinal;

var U: RawUTF8;

    wasString: boolean;

begin

  VariantToUTF8(variant(Elem),U,wasString);

  if pointer(U)=nil then

    result := HASH_ONVOIDCOLISION else

    result := Hasher(0,pointer(U),UpperCopy(pointer(U),U)-pointer(U));

end;



{$endif NOVARIANTS}



procedure TDynArrayHashed.InitSpecific(aTypeInfo: pointer; var aValue;

  aKind: TDynArrayKind; aCountPointer: PInteger=nil; aCaseInsensitive: boolean=false);

var Comp: TDynArraySortCompare;

    Hasher: TDynArrayHashOne;

begin

  Comp := DYNARRAY_SORTFIRSTFIELD[aCaseInsensitive,aKind];

  Hasher := DYNARRAY_HASHFIRSTFIELD[aCaseInsensitive,aKind];

  if (@Hasher=nil) or (@Comp=nil) then

    raise ESynException.Create('TDynArrayHashed.InitSpecific wrong aKind');

  Init(aTypeInfo,aValue,Hasher,Comp,nil,aCountPointer,aCaseInsensitive);

  {$ifdef UNDIRECTDYNARRAY}with InternalDynArray do{$endif} begin

    fKnownType := aKind;

    fKnownSize := KNOWNTYPE_SIZE[aKind];

  end;

end;



procedure TDynArrayHashed.Init(aTypeInfo: pointer; var aValue;

      aHashElement: TDynArrayHashOne=nil; aCompare: TDynArraySortCompare=nil;

      aHasher: THasher=nil; aCountPointer: PInteger=nil; aCaseInsensitive: boolean=false);

var aKind: TDynArrayKind;

begin

  {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$else}inherited{$endif}

    Init(aTypeInfo,aValue,aCountPointer);

  fEventCompare := nil;

  if @aHasher=nil then

    fHasher := DefaultHasher else

    fHasher := aHasher;

  if (@aHashElement=nil) or (@aCompare=nil) then begin

    // it's faster to retrieve now the hashing/compare function than in HashOne

    aKind := {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}ToKnownType;

    if @aHashElement=nil then

      aHashElement := DYNARRAY_HASHFIRSTFIELD[aCaseInsensitive,aKind];

    if @aCompare=nil then

      aCompare := DYNARRAY_SORTFIRSTFIELD[aCaseInsensitive,aKind];

  end;

  fHashElement := aHashElement;

  {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare := aCompare;

  fHashs := nil;

  fHashFindCount := 0;

  fHashCountTrigger := 32;

end;



//var TDynArrayHashedCollisionCount: cardinal;



function TDynArrayHashed.HashFind(aHashCode: cardinal): integer;

var first,last: integer;

    h: cardinal;

    P: PAnsiChar;

begin

  if fHashs=nil then begin // Count=0 or Count<fHashCountTrigger

    if Assigned(fHashElement) then begin

      P := fValue^;

      for result := 0 to Count-1 do begin

        h := fHashElement(P^,fHasher);

        if h=HASH_VOID then

          h := HASH_ONVOIDCOLISION;

        if h=aHashCode then

          exit else

          inc(P,ElemSize);

      end;

    end;

    result := -1;

    exit;

  end;

  if aHashCode=HASH_VOID then

    aHashCode := HASH_ONVOIDCOLISION; // 0 means void slot in the loop below

  result := (aHashCode-1) and (fHashsCount-1); // fHashs[] has a power of 2 length

  last := fHashsCount;

  first := result;

  repeat

    with fHashs[result] do

    if Hash=aHashCode then begin

      result := Index;

      exit;

    end else

    if Hash=HASH_VOID then

      break; // not found

    inc(result);

    if result=last then

      // reached the end -> search once from fHash[0] to fHash[first-1]

      if result=first then

        break else begin

        result := 0;

        last := first;

      end;

  until false;

  result := -1;

end;



function TDynArrayHashed.HashFind(aHashCode: cardinal; const Elem): integer;

var first,last: integer;

    P: PAnsiChar;

begin

  if fHashs=nil then begin // e.g. Count<fHashCountTrigger

    result := Scan(Elem);

    exit;

  end;

  if aHashCode=HASH_VOID then

    aHashCode := HASH_ONVOIDCOLISION; // 0 means void slot in the loop below

  result := (aHashCode-1) and (fHashsCount-1); // fHashs[] has a power of 2 length

  last := fHashsCount;

  first := result;

  repeat

    with fHashs[result] do

    if Hash=aHashCode then begin

      P := PAnsiChar(fValue^)+Index*ElemSize;

      if not Assigned(fEventCompare) then

        if @{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare<>nil then begin

          if {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare(P^,Elem)=0 then begin

            result := Index;

            exit; // found -> returns index in dynamic array

          end;

        end else begin

          if {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}ElemEquals(P^,Elem) then begin

            result := Index;

            exit; // found -> returns index in dynamic array

          end;

        end else

        if fEventCompare(P^,Elem)=0 then begin

          result := Index;

          exit; // found -> returns index in dynamic array

        end;

    end else

    if Hash=HASH_VOID then begin

      result := -(result+1);

      exit; // not found -> returns void index in fHashs[] as negative

    end;

    // fHashs[Hash mod fHashsCount].Hash collision -> search next item

    {$ifdef DYNARRAYHASHCOLLISIONCOUNT}

    inc(fHashFindCollisions);

    {$endif}

    //inc(TDynArrayHashedCollisionCount);

    inc(result);

    if result=last then

      // reached the end -> search once from fHash[0] to fHash[first-1]

      if result=first then

        break else begin

        result := 0;

        last := first;

      end;

  until false;

  raise ESynException.Create('HashFind fatal collision'); // should never be here

end;



function TDynArrayHashed.GetHashFromIndex(aIndex: Integer): Cardinal;

var P: pointer;

begin

  if (cardinal(aIndex)>=cardinal(Count)) or not Assigned(fHashElement) then

    result := 0 else begin

    // it's faster to rehash than to loop in fHashs[].Index values

    // and it will also work with Count<fHashCountTrigger

    P := PAnsiChar(fValue^)+cardinal(aIndex)*ElemSize;

    result := fHashElement(P^,fHasher);

    if result=HASH_VOID then

      result := HASH_ONVOIDCOLISION; // 0 means void slot in the loop below

  end;

end;



function TDynArrayHashed.IsHashElementWithoutCollision: integer;

var i,j: integer;

    h: cardinal;

begin

  if Count>0 then begin

    ReHash;

    for i := 0 to fHashsCount-1 do begin

      h := fHashs[i].Hash;

      if h=HASH_VOID then

        continue;

      result := fHashs[i].Index;

      for j := i+1 to fHashsCount-1 do

        if fHashs[j].Hash=h then

          exit; // found duplicate

    end;

  end;

  result := -1;

end;



function TDynArrayHashed.ReHash(aHasher: TOnDynArrayHashOne=nil): boolean;

var i, n, cap, ndx: integer;

    P: PAnsiChar;

    aHashCode: cardinal;

begin

  result := false;

  fHashs := nil;

  n := Count;

  if (n=0) or (n<fHashCountTrigger) then

    exit; // hash only if needed, and avoid GPF after TDynArray.Clear (Count=0)

  if (not Assigned(aHasher)) and (not Assigned(fHashElement)) then

    exit;

  // find nearest power of two for new fHashs[] size

  cap := Capacity*2; // Capacity sounds better than Count

  fHashsCount := 256;

  while fHashsCount<cap do

    fHashsCount := fHashsCount shl 1;

  SetLength(fHashs,fHashsCount); // fill all fHashs[]=HASH_VOID=0

  // fill fHashs[] from all existing items

  P := fValue^;

  for i := 0 to n-1 do begin

    if Assigned(aHasher) then

      aHashCode := aHasher(P^) else

      aHashCode := fHashElement(P^,fHasher);

    if aHashCode=HASH_VOID then

      aHashCode := HASH_ONVOIDCOLISION; // 0 means void slot in the loop below

    ndx := HashFind(aHashCode,P^);

    if ndx<0 then

      // >=0 -> already found -> not necessary to add duplicated hash

      with fHashs[-ndx-1] do begin

        Hash := aHashCode;

        Index := i;

      end;

    inc(P,ElemSize);

  end;

  result := true;

end;





{ TObjectDynArrayWrapper }



constructor TObjectDynArrayWrapper.Create(var aValue);

begin

  fValue := @aValue;

end;



destructor TObjectDynArrayWrapper.Destroy;

begin

  Clear;

  inherited;

end;



function TObjectDynArrayWrapper.Find(Instance: TObject): integer;

begin

  for result := 0 to fCount-1 do

    if TObjectDynArray(fValue^)[result]=Instance then

      exit;

  result := -1;

end;



function TObjectDynArrayWrapper.Add(Instance: TObject): integer;

var cap: integer;

begin

  cap := length(TObjectDynArray(fValue^));

  if cap<=fCount then begin

    if cap<256 then

      inc(cap,64) else

      inc(cap,256+cap shr 3);

    SetLength(TObjectDynArray(fValue^),cap);

  end;

  result := fCount;

  TObjectDynArray(fValue^)[result] := Instance;

  inc(fCount);

end;



procedure TObjectDynArrayWrapper.Delete(Index: integer);

begin

  if cardinal(Index)>=cardinal(fCount) then

    exit; // avoid Out of range

  TObjectDynArray(fValue^)[Index].Free;

  dec(fCount);

  if fCount>Index then

    MoveFast(TObjectDynArray(fValue^)[Index+1],TObjectDynArray(fValue^)[Index],

      (fCount-Index)*sizeof(pointer));

end;



procedure TObjectDynArrayWrapper.Clear;

var i: integer;

begin

  if fValue^<>nil then begin

    for i := fCount-1 downto 0 do

    try

      TObjectDynArray(fValue^)[i].Free;

    except

      on Exception do;

    end;

    TObjectDynArray(fValue^) := nil; // set capacity to 0

    fCount := 0;

  end else

    if fCount>0 then

      raise ESynException.Create('You MUST define your IObjectDynArray field '+

        'BEFORE the corresponding dynamic array');

end;



function TObjectDynArrayWrapper.Count: integer;

begin

  result := fCount;

end;



function TObjectDynArrayWrapper.Capacity: integer;

begin

  result := length(TObjectDynArray(fValue^));

end;



procedure TObjectDynArrayWrapper.Sort(Compare: TDynArraySortCompare);

var QuickSort: TDynArrayQuickSort;

begin

  if (@Compare<>nil) and (fCount>0) then begin

    Quicksort.Compare := @Compare;

    Quicksort.Value := fValue^;

    Quicksort.ElemSize := sizeof(pointer);

    Quicksort.QuickSort(0,fCount-1);

  end;

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;





{ wrapper functions to T*ObjArr types }



function ObjArrayAdd(var aObjArray; aItem: TObject): integer;

var a: TObjectDynArray absolute aObjArray;

begin

  result := length(a);

  SetLength(a,result+1);

  a[result] := aItem;

end;



procedure ObjArrayAddOnce(var aObjArray; aItem: TObject);

begin

  if not PtrUIntScanExists(pointer(aObjArray),

     length(TObjectDynArray(aObjArray)),PtrUInt(aItem)) then

    ObjArrayAdd(aObjArray,aItem);

end;



procedure ObjArraySetLength(var aObjArray; aLength: integer);

begin

  SetLength(TObjectDynArray(aObjArray),aLength);

end;



function ObjArrayFind(const aObjArray; aItem: TObject): integer;

begin

  result := PtrUIntScanIndex(pointer(aObjArray),

    length(TObjectDynArray(aObjArray)),PtrUInt(aItem));

end;



procedure ObjArrayDelete(var aObjArray; aItemIndex: integer);

var n: integer;

    a: TObjectDynArray absolute aObjArray;

begin

  n := length(a);

  if cardinal(aItemIndex)>=cardinal(n) then

    exit; // out of range

  a[aItemIndex].Free;

  dec(n);

  if n>aItemIndex then

    MoveFast(a[aItemIndex+1],a[aItemIndex],(n-aItemIndex)*sizeof(TObject));

  SetLength(a,n);

end;



function ObjArrayDelete(var aObjArray; aItem: TObject): integer;

begin

  result := ObjArrayFind(aObjArray,aItem);

  if result>=0 then

    ObjArrayDelete(aObjArray,result);

end;



procedure ObjArraySort(var aObjArray; Compare: TDynArraySortCompare);

var QuickSort: TDynArrayQuickSort;

    n: integer;

begin

  n := length(TObjectDynArray(aObjArray));

  if (@Compare<>nil) and (n>0) then begin

    Quicksort.Compare := @Compare;

    Quicksort.Value := pointer(aObjArray);

    Quicksort.ElemSize := sizeof(pointer);

    Quicksort.QuickSort(0,n-1);

  end;

end;



procedure ObjArrayClear(var aObjArray);

var i: integer;

    a: TObjectDynArray absolute aObjArray;

begin

  if a<>nil then begin

    for i := 0 to length(a)-1 do

      a[i].Free;

    a := nil;

  end;

end;



function ObjArrayToJSON(const aObjArray; Options: TTextWriterWriteObjectOptions): RawUTF8;

begin

  with DefaultTextWriterJSONClass.CreateOwnedStream do

  try

    if woEnumSetsAsText in Options then

      CustomOptions := CustomOptions+[twoEnumSetsAsTextInRecord];

    AddObjArrayJSON(aObjArray,Options);

    SetText(result);

  finally

    Free;

  end;

end;



procedure ObjArrayObjArrayClear(var aObjArray);

var i: integer;

    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: integer;

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): integer;

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: integer;

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): integer;

begin

  result := PtrUIntScanIndex(pointer(aInterfaceArray),

    length(TInterfaceDynArray(aInterfaceArray)),PtrUInt(aItem));

end;



procedure InterfaceArrayDelete(var aInterfaceArray; aItemIndex: integer);

var n: integer;

    a: TInterfaceDynArray absolute aInterfaceArray;

begin

  n := length(a);

  if cardinal(aItemIndex)>=cardinal(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): integer;

begin

  result := InterfaceArrayFind(aInterfaceArray,aItem);

  if result>=0 then

    InterfaceArrayDelete(aInterfaceArray,result);

end;



{$endif DELPHI5OROLDER}





{ TObjectHash }



const

  COUNT_TO_START_HASHING = 32;



function TObjectHash.Find(Item: TObject): integer;

var n: integer;

begin

  n := Count;

  if n<=COUNT_TO_START_HASHING then

    result := Scan(Item,n) else

    result := HashFind(Hash(Item),Item);

end;



function TObjectHash.Scan(Item: TObject; ListCount: integer): integer;

begin

  for result := 0 to ListCount-1 do

    if Compare(Get(result),Item) then

      exit;

  result := -1;

end;



function TObjectHash.HashFind(aHashCode: cardinal; Item: TObject): integer;

var n, first: integer;

    looped: boolean;

begin

  looped := false;

  if fHashs=nil then

    HashInit(Count);

  n := length(fHashs);

  result := (aHashCode-1) and (n-1); // fHashs[] has a power of 2 length

  first := result;

  repeat

    with fHashs[result] do

    if Hash=aHashCode then begin

      if Compare(Get(Index),Item) then begin

        result := Index;

        exit; // found -> returns index in list

      end;

    end else

    if Hash=0 then begin

      result := -(result+1);

      exit; // not found -> returns void index in fHashs[] as negative

    end;

    // hash colision -> search next item

    inc(result);

    if result=n then

      // reached the end -> search once from fHash[0] to fHash[first-1]

      if looped then

        Break else begin

        result := 0;

        n := first;

        looped := true;

      end;

  until false;

  raise ESynException.CreateUTF8('%.HashFind fatal collision',[self]);

end;



procedure TObjectHash.HashInit(aCountToHash: integer);

var PO2,i,ndx: integer;

    H: cardinal;

    O: TObject;

begin

  assert(fHashs=nil);

  // find nearest power of two for new fHashs[] size

  PO2 := 256;

  while PO2<aCountToHash*2 do

    PO2 := PO2 shl 1;

  SetLength(fHashs,PO2);

  // hash all items

  for i := 0 to aCountToHash-1 do begin

    O := Get(i);

    H := Hash(O);

    ndx := HashFind(H,O);

    if ndx>=0 then

      raise ESynException.CreateUTF8('%.HashInit found dup at index %',[self,ndx]);

    with fHashs[-ndx-1] do begin

      Hash := H;

      Index := i;

    end;

  end;

end;



procedure TObjectHash.Invalidate;

begin

  fHashs := nil; // force HashInit call on next Find()

end;



function TObjectHash.EnsureJustAddedNotDuplicated: boolean;

var H: cardinal;

    lastNdx,ndx: integer;

    lastObject: TObject;

begin

  lastNdx := Count-1;

  lastObject := Get(lastNdx);

  if lastObject=nil then

    raise ESynException.CreateUTF8('Invalid %.EnsureJustAddedNotDuplicated call',[self]);

  if lastNdx<COUNT_TO_START_HASHING then begin

    result := Scan(lastObject,lastNdx)<0; // O(n) search if not worth it

    exit;

  end;

  if lastNdx*2-lastNdx shr 3>length(fHashs) then begin

    fHashs := nil;

    HashInit(lastNdx); // re-compute fHashs up to Count-1 if not enough void positions

  end;

  H := Hash(lastObject);

  ndx := HashFind(H,lastObject);

  if ndx>=0 then begin

    result := false; // duplicate found

    exit;

  end;

  with fHashs[-ndx-1] do begin

    Hash := H;

    Index := lastNdx;

  end;

  result := true; // last inserted item is OK

end;





{ TInterfacedObjectWithCustomCreate }



constructor TInterfacedObjectWithCustomCreate.Create;

begin // nothing to do by default - overridden constructor may add custom code

end;



procedure TInterfacedObjectWithCustomCreate.RefCountUpdate(Release: boolean);

begin

  if Release then

    _Release else

    _AddRef;

end;





{ TAutoLock }



type

  /// used by TAutoLocker.ProtectMethod and TSynLocker.ProtectMethod

  TAutoLock = class(TInterfacedObject)

  protected

    fLock: PSynLocker;

  public

    constructor Create(aLock: PSynLocker);

    destructor Destroy; override;

  end;



constructor TAutoLock.Create(aLock: PSynLocker);

begin

  fLock := aLock;

  fLock^.Lock;

end;



destructor TAutoLock.Destroy;

begin

  fLock^.UnLock;

end;





{ TSynLocker }



procedure TSynLocker.Init;

begin

  InitializeCriticalSection(fSection);

  PaddingMaxUsedIndex := -1;

end;



procedure TSynLocker.Done;

var i: integer;

begin

  for i := 0 to PaddingMaxUsedIndex do

    VarClear(variant(Padding[i]));

  DeleteCriticalSection(fSection);

end;



procedure TSynLocker.Lock;

begin

  EnterCriticalSection(fSection);

end;



procedure TSynLocker.UnLock;

begin

  LeaveCriticalSection(fSection);

end;



function TSynLocker.TryLock: boolean;

begin

  result := TryEnterCriticalSection(fSection){$ifdef LINUX}{$ifdef FPC}<>0{$endif}{$endif};

end;



function TSynLocker.ProtectMethod: IUnknown;

begin

  result := TAutoLock.Create(@self);

end;



{$ifndef NOVARIANTS}



function TSynLocker.GetVariant(Index: integer): Variant;

begin

  if (Index>=0) and (Index<=PaddingMaxUsedIndex) then // PaddingMaxUsedIndex may be -1

    try

      EnterCriticalSection(fSection);

      result := variant(Padding[Index]);

    finally

      LeaveCriticalSection(fSection);

    end else

    VarClear(result);

end;



procedure TSynLocker.SetVariant(Index: integer; const Value: Variant);

begin

  if cardinal(Index)<=high(Padding) then

    try

      EnterCriticalSection(fSection);

      if Index>PaddingMaxUsedIndex then

        PaddingMaxUsedIndex := Index;

      variant(Padding[Index]) := Value;

    finally

      LeaveCriticalSection(fSection);

    end;

end;



function TSynLocker.GetInt64(Index: integer): Int64;

begin

  if (Index>=0) and (Index<=PaddingMaxUsedIndex) then

    try

      EnterCriticalSection(fSection);

      if not VariantToInt64(variant(Padding[index]),result) then

        result := 0;

    finally

      LeaveCriticalSection(fSection);

    end else

    result := 0;

end;



procedure TSynLocker.SetInt64(Index: integer; const Value: Int64);

begin

  if cardinal(Index)<=high(Padding) then

    try

      EnterCriticalSection(fSection);

      if Index>PaddingMaxUsedIndex then

        PaddingMaxUsedIndex := Index;

      variant(Padding[Index]) := Value;

    finally

      LeaveCriticalSection(fSection);

    end;

end;



function TSynLocker.GetUnLockedInt64(Index: integer): Int64;

begin

  if (Index<0) or (Index>PaddingMaxUsedIndex) or

     not VariantToInt64(variant(Padding[index]),result) then

    result := 0;

end;



procedure TSynLocker.SetUnlockedInt64(Index: integer; const Value: Int64);

begin

  if cardinal(Index)<=high(Padding) then begin

    if Index>PaddingMaxUsedIndex then

      PaddingMaxUsedIndex := Index;

    variant(Padding[Index]) := Value;

  end;

end;



function TSynLocker.GetPointer(Index: integer): Pointer;

begin

  if (Index>=0) and (Index<=PaddingMaxUsedIndex) then

    try

      EnterCriticalSection(fSection);

      with Padding[index] do

        if VType=varUnknown then

          result := VUnknown else

          result := nil;

    finally

      LeaveCriticalSection(fSection);

    end else

    result := nil;

end;



procedure TSynLocker.SetPointer(Index: integer; const Value: Pointer);

begin

  if cardinal(Index)<=high(Padding) then

    try

      EnterCriticalSection(fSection);

      if Index>PaddingMaxUsedIndex then

        PaddingMaxUsedIndex := Index;

      with Padding[index] do begin

        if VType<>varUnknown then begin

          VarClear(PVariant(@VType)^);

          VType := varUnknown;

        end;

        VUnknown := Value;

      end;

    finally

      LeaveCriticalSection(fSection);

    end;

end;



function TSynLocker.GetUTF8(Index: integer): RawUTF8;

var wasString: Boolean;

begin

  if (Index>=0) and (Index<=PaddingMaxUsedIndex) then

    try

      EnterCriticalSection(fSection);

      VariantToUTF8(variant(Padding[Index]),result,wasString);

      if not wasString then

        result := '';

    finally

      LeaveCriticalSection(fSection);

    end else

    result := '';

end;



procedure TSynLocker.SetUTF8(Index: integer; const Value: RawUTF8);

begin

  if cardinal(Index)<=high(Padding) then

    try

      EnterCriticalSection(fSection);

      if Index>PaddingMaxUsedIndex then

        PaddingMaxUsedIndex := Index;

      RawUTF8ToVariant(Value,Padding[Index],varString);

    finally

      LeaveCriticalSection(fSection);

    end;

end;



function TSynLocker.LockedInt64Increment(Index: integer; const Increment: Int64): Int64;

begin

  if cardinal(Index)<=high(Padding) then

    try

      EnterCriticalSection(fSection);

      result := 0;

      if Index<=PaddingMaxUsedIndex then

        VariantToInt64(variant(Padding[index]),result) else

        PaddingMaxUsedIndex := Index;

      variant(Padding[Index]) := Int64(result+Increment);

    finally

      LeaveCriticalSection(fSection);

    end else

    result := 0;

end;



function TSynLocker.LockedExchange(Index: integer; const Value: Variant): Variant;

begin

  if cardinal(Index)<=high(Padding) then

    try

      EnterCriticalSection(fSection);

      with Padding[index] do begin

        if Index<=PaddingMaxUsedIndex then

          result := PVariant(@VType)^ else begin

          PaddingMaxUsedIndex := Index;

          VarClear(result);

        end;

        PVariant(@VType)^ := Value;

      end;

    finally

      LeaveCriticalSection(fSection);

    end else

    VarClear(result);

end;



function TSynLocker.LockedPointerExchange(Index: integer; Value: pointer): pointer;

begin

  if cardinal(Index)<=high(Padding) then

    try

      EnterCriticalSection(fSection);

      with Padding[index] do begin

        if Index<=PaddingMaxUsedIndex then

          if VType=varUnknown then

            result := VUnknown else begin

            VarClear(PVariant(@VType)^);

            result := nil;

          end else begin

          PaddingMaxUsedIndex := Index;

          result := nil;

        end;

        VType := varUnknown;

        VUnknown := Value;

      end;

    finally

      LeaveCriticalSection(fSection);

    end else

    result := nil;

end;



{$endif NOVARIANTS}





{ TInterfacedObjectLocked }



constructor TInterfacedObjectLocked.Create;

begin

  inherited Create;

  fSafe.Init;

end;



destructor TInterfacedObjectLocked.Destroy;

begin

  inherited Destroy;

  fSafe.Done;

end;





{ TPersistentWithCustomCreate }



constructor TPersistentWithCustomCreate.Create;

begin // nothing to do by default - overridden constructor may add custom code

end;





{ TSynPersistent }



constructor TSynPersistent.Create;

begin // nothing to do by default - overridden constructor may add custom code

end;



procedure TSynPersistent.AssignError(Source: TSynPersistent);

var

  SourceName: string;

begin

  if Source <> nil then

    SourceName := Source.ClassName else

    SourceName := 'nil';

  raise EConvertError.CreateFmt('Cannot assign a %s to a %s', [SourceName, ClassName]);

end;



procedure TSynPersistent.AssignTo(Dest: TSynPersistent);

begin

  Dest.AssignError(Self);

end;



procedure TSynPersistent.Assign(Source: TSynPersistent);

begin

  if Source<>nil then

    Source.AssignTo(Self) else

    AssignError(nil);

end;





{$ifndef FPC_OR_PUREPASCAL}



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}





{ TSynPersistentLocked }



constructor TSynPersistentLocked.Create;

begin

  inherited Create;

  fSafe.Init;

end;



destructor TSynPersistentLocked.Destroy;

begin

  inherited Destroy;

  fSafe.Done;

end;





{ ****************** text buffer and JSON functions and classes ********* }



{ TTextWriter }



procedure TTextWriter.Add(Value: PtrInt);

var tmp: array[0..23] of AnsiChar;

    P: PAnsiChar;

    Len: integer;

begin

  if BEnd-B<=16 then

    FlushToStream;

  P := StrInt32(@tmp[23],value);

  Len := @tmp[23]-P;

  MoveFast(P[0],B[1],Len);

  inc(B,Len);

end;



procedure TTextWriter.AddCurr64(const Value: Int64);

var tmp: array[0..31] of AnsiChar;

    P: PAnsiChar;

    Len: integer;

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);

  MoveFast(P[0],B[1],Len);

  inc(B,Len);

end;



procedure TTextWriter.AddCurr64(const Value: currency);

begin

  AddCurr64(PInt64(@Value)^);

end;



procedure TTextWriter.AddTimeLog(Value: PInt64);

begin

  if BEnd-B<=31 then

    FlushToStream;

  inc(B,PTimeLogBits(Value)^.Text(B+1,true,'T'));

end;



procedure TTextWriter.AddDateTime(Value: PDateTime; FirstChar: AnsiChar; QuoteChar: AnsiChar);

begin

  if (Value^=0) and (QuoteChar=#0) then

    exit;

  if BEnd-B<=21 then

    FlushToStream;

  inc(B);

  if QuoteChar<>#0 then

    B^ := QuoteChar else

    dec(B);

  if Value^<>0 then begin

    inc(B);

    if trunc(Value^)<>0 then begin

      DateToIso8601PChar(Value^,B,true);

      inc(B,10);

    end;

    if frac(Value^)<>0 then begin

      TimeToIso8601PChar(Value^,B,true,FirstChar);

      inc(B,9);

    end;

    dec(B);

  end;

  if QuoteChar<>#0 then begin

    inc(B);

    B^ := QuoteChar;

  end;

end;



procedure TTextWriter.AddDateTime(const Value: TDateTime);

begin

  if Value=0 then

    exit;

  if BEnd-B<=19 then

    FlushToStream;

  inc(B);

  if trunc(Value)<>0 then begin

    DateToIso8601PChar(Value,B,true);

    inc(B,10);

  end;

  if frac(Value)<>0 then begin

    TimeToIso8601PChar(Value,B,true,'T');

    inc(B,9);

  end;

  dec(B);

end;



procedure TTextWriter.AddU(Value: cardinal);

var tmp: array[0..15] of AnsiChar;

    P: PAnsiChar;

    Len: integer;

begin

  if BEnd-B<=16 then

    FlushToStream;

  P := StrUInt32(@tmp[15],Value);

  Len := @tmp[15]-P;

  MoveFast(P[0],B[1],Len);

  inc(B,Len);

end;



procedure TTextWriter.Add(Value: Extended; precision: integer);

var S: ShortString;

begin

  if Value=0 then

    Add('0') else

    AddNoJSONEscape(@S[1],ExtendedToString(S,Value,precision));

end;



procedure TTextWriter.AddDouble(Value: double);

var S: ShortString;

begin

  if Value=0 then

    Add('0') else

    AddNoJSONEscape(@S[1],ExtendedToString(S,Value,DOUBLE_PRECISION));

end;



procedure TTextWriter.AddSingle(Value: single);

var S: ShortString;

begin

  if Value=0 then

    Add('0') else

    AddNoJSONEscape(@S[1],ExtendedToString(S,Value,SINGLE_PRECISION));

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^ := '-';

  end else

    P := StrUInt64(@tmp[23],Value);

  Len := @tmp[23]-P;

  MoveFast(P[0],B[1],Len);

  inc(B,Len);

end;

{$endif}



procedure TTextWriter.Add(Value: boolean);

begin

  if Value then

    AddShort('true') else

    AddShort('false');

end;



procedure TTextWriter.AddFloatStr(P: PUTF8Char);

var L: cardinal;

begin

  L := StrLen(P);

  if (L=0) or (L>30) then

    Add('0') else begin

    if BEnd-B<=31 then

      FlushToStream;

    inc(B);

    if PWord(P)^=ord('-')+ord('.')shl 8 then begin

      PWord(B)^ := ord('-')+ord('0')shl 8; // '-.3' -> '-0.3'

      inc(B,2);

      inc(P);

      dec(L);

    end else

    if P^='.' then begin

      B^ := '0'; // '.5' -> '0.5'

      inc(B);

    end;

    MoveFast(P^,B^,L);

    inc(B,L-1);

  end;

end;



procedure TTextWriter.Add(c: AnsiChar);

begin

  if B>=BEnd then

    FlushToStream;

  B[1] := c;

  inc(B);

end;



procedure TTextWriter.Add(c1, c2: AnsiChar);

begin

  if BEnd-B<=1 then

    FlushToStream;

  B[1] := c1;

  B[2] := c2;

  inc(B,2);

end;



procedure TTextWriter.Add(const guid: TGUID);

begin

  if BEnd-B<=36 then

    FlushToStream;

  GUIDToText(B+1,@guid);

  inc(B,36);

end;



procedure TTextWriter.AddCR;

begin

  if BEnd-B<=1 then

    FlushToStream;

  PWord(B+1)^ := 13+10 shl 8; // CR + LF

  inc(B,2);

end;



procedure TTextWriter.AddEndOfLine(aLevel: TSynLogInfo=sllNone);

var i: integer;

begin

  if BEnd-B<=1 then

    FlushToStream;

  if twoEndOfLineCRLF in fCustomOptions then begin

    PWord(B+1)^ := 13+10 shl 8; // CR + LF

    inc(B,2);

  end else begin

    B[1] := #13; // CR

    inc(B);

  end;

  if fEchos<>nil then begin

    fEchoStart := EchoFlush;

    for i := length(fEchos)-1 downto 0 do // for MultiEventRemove() below

    try

      fEchos[i](self,aLevel,fEchoBuf);

    except // remove callback in case of exception during echoing in user code

      MultiEventRemove(fEchos,i);

    end;

    fEchoBuf := '';

  end;

end;



procedure TTextWriter.AddCRAndIndent;

var ntabs: cardinal;

begin

  if B^=#9 then

    exit; // we most probably just added an indentation level

  ntabs := fHumanReadableLevel;

  if ntabs>=cardinal(fTempBufSize) then

    exit; // avoid buffer overflow

  if BEnd-B<=Integer(ntabs)+1 then

    FlushToStream;

  PWord(B+1)^ := 13+10 shl 8; // CR + LF

  FillcharFast(B[3],ntabs,9); // indentation using tabs

  inc(B,ntabs+2);

end;



procedure TTextWriter.AddChars(aChar: AnsiChar; aCount: integer);

begin

  if cardinal(aCount-1)>=cardinal(fTempBufSize) then

    exit; // avoid buffer overflow

  if BEnd-B<=aCount then

    FlushToStream;

  FillcharFast(B[1],aCount,ord(aChar));

  inc(B,aCount);

end;



procedure TTextWriter.Add2(Value: integer);

begin

  if BEnd-B<=3 then

    FlushToStream;

  if cardinal(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.Add4(Value: integer);

begin

  if BEnd-B<=5 then

    FlushToStream;

  if cardinal(Value)>9999 then

    PCardinal(B+1)^ := $30303030 else // '0000,' if overflow

    YearToPChar(Value,B+1);

  inc(B,5);

  B^ := ',';

end;



var // can be safely made global since timing is multi-thread safe

  GlobalLogTime: array[boolean] of record

    time: TSystemTime;

    clock: cardinal; // avoid slower API call

  end;



procedure TTextWriter.AddCurrentLogTime(LocalTime, Use16msCache: boolean);

var Ticks: cardinal;

begin

  if BEnd-B<=17 then

    FlushToStream;

  with GlobalLogTime[LocalTime] do begin

    if Use16msCache then begin

      Ticks := GetTickCount; // this call is very fast (just one integer mul)

      if clock<>Ticks then begin // typically in range of 10-16 ms

        clock := Ticks;

        if LocalTime then

          GetLocalTime(time) else

          {$ifdef MSWINDOWS}

          GetSystemTime(time);

          {$else}

          GetNowUTCSystem(time);

          {$endif}

      end;

    end;

    inc(B);

    YearToPChar(time.{$ifdef MSWINDOWS}wYear{$else}Year{$endif},B);

    PWord(B+4)^ := TwoDigitLookupW[time.{$ifdef MSWINDOWS}wMonth{$else}Month{$endif}];

    PWord(B+6)^ := TwoDigitLookupW[time.{$ifdef MSWINDOWS}wDay{$else}Day{$endif}];

    B[8] := ' ';

    PWord(B+9)^ := TwoDigitLookupW[time.{$ifdef MSWINDOWS}wHour{$else}Hour{$endif}];

    PWord(B+11)^ := TwoDigitLookupW[time.{$ifdef MSWINDOWS}wMinute{$else}Minute{$endif}];

    PWord(B+13)^ := TwoDigitLookupW[time.{$ifdef MSWINDOWS}wSecond{$else}Second{$endif}];

    PWord(B+15)^ := TwoDigitLookupW[time.{$ifdef MSWINDOWS}wMilliseconds{$else}Millisecond{$endif} shr 4];

    B[17] := ' ';

    inc(B,16);

  end;

end;



procedure TTextWriter.AddMicroSec(MS: cardinal);

function Value3Digits(V: Cardinal; P: PUTF8Char): Cardinal;

begin

  PWord(P+1)^ := TwoDigitLookupW[V mod 100];

  P^ := AnsiChar((V div 100)mod 10+48);

  result := V div 1000;

end;

begin // 00.000.000

  if BEnd-B<=17 then

    FlushToStream;

  B[3] := '.';

  B[7] := '.';

  inc(B);

  MS := Value3Digits(Value3Digits(MS,B+7),B+3);

  if MS>99 then

    MS := 99;

  PWord(B)^:= TwoDigitLookupW[MS];

  inc(B,9);

end;



procedure TTextWriter.Add3(Value: integer);

begin

  if BEnd-B<=4 then

    FlushToStream;

  if cardinal(Value)>999 then

    PCardinal(B+1)^ := $303030 else // '0000,' if overflow

    PCardinal(B+1)^ := TwoDigitLookupW[Value div 10]+

      ord(Value mod 10+48)shl 16;

  inc(B,4);

  B^ := ',';

end;



procedure TTextWriter.AddCSVInteger(const Integers: array of Integer);

var i: integer;

begin

  if length(Integers)=0 then

    exit;

  for i := 0 to high(Integers) do begin

    Add(Integers[i]);

    Add(',');

  end;

  CancelLastComma;

end;



procedure TTextWriter.AddCSVDouble(const Doubles: array of double);

var i: integer;

begin

  if length(Doubles)=0 then

    exit;

  for i := 0 to high(Doubles) do begin

    AddDouble(Doubles[i]);

    Add(',');

  end;

  CancelLastComma;

end;



procedure TTextWriter.AddCSVUTF8(const Values: array of RawUTF8);

var i: integer;

begin

  if length(Values)=0 then

    exit;

  for i := 0 to high(Values) do begin

    Add('"');

    AddJSONEscape(pointer(Values[i]));

    Add('"',',');

  end;

  CancelLastComma;

end;



procedure TTextWriter.AddCSVConst(const Values: array of const);

var i: integer;

begin

  if length(Values)=0 then

    exit;

  for i := 0 to high(Values) do begin

    AddJSONEscape(Values[i]);

    Add(',');

  end;

  CancelLastComma;

end;



procedure TTextWriter.Add(const Values: array of const);

var i: Integer;

begin

  for i := 0 to high(Values) do

    AddJSONEscape(Values[i]);

end;



procedure TTextWriter.WriteObject(Value: TObject; Options: TTextWriterWriteObjectOptions);

var i: integer;

begin

  if Value<>nil then

    if Value.InheritsFrom(Exception) then

      Add('{"%":"%"}',[Value.ClassType,Exception(Value).Message]) else

    if Value.InheritsFrom(TRawUTF8List) then

    with TRawUTF8List(Value) do begin

      self.Add('[');

      for i := 0 to Count-1 do begin

        self.Add('"');

        self.AddJSONEscape(pointer(fList[i]));

        self.Add('"',',');

      end;

      self.CancelLastComma;

      self.Add(']');

      exit;

    end else

    if Value.InheritsFrom(TStrings) then

    with TStrings(Value) do begin

      self.Add('[');

      for i := 0 to Count-1 do begin

        self.Add('"');

        {$ifdef UNICODE}

        self.AddJSONEscapeW(pointer(Strings[i]),Length(Strings[i]));

        {$else}

        self.AddJSONEscapeAnsiString(Strings[i]);

        {$endif}

        self.Add('"',',');

      end;

      self.CancelLastComma;

      self.Add(']');

      exit;

    end else

    if not(woFullExpand in Options) or

       not (Value.InheritsFrom(TList)

       {$ifndef LVCL} or Value.InheritsFrom(TCollection){$endif}) then

      Value := nil;

  if Value=nil then begin

    AddShort('null');

    exit;

  end;

  Add('{');

  AddInstanceName(Value,':');

  Add('[');

  if Value.InheritsFrom(TList) then

    for i := 0 to TList(Value).Count-1 do

      AddInstanceName(TList(Value).List[i],',')

  {$ifndef LVCL} else

  if Value.InheritsFrom(TCollection) then

    for i := 0 to TCollection(Value).Count-1 do

      AddInstanceName(TCollection(Value).Items[i],',') {$endif} ;

  CancelLastComma;

  Add(']','}');

end;



function TTextWriter.InternalJSONWriter: TTextWriter;

begin

  if fInternalJSONWriter=nil then

    fInternalJSONWriter := DefaultTextWriterJSONClass.CreateOwnedStream else

    fInternalJSONWriter.CancelAll;

  result := fInternalJSONWriter;

end;



procedure TTextWriter.AddJSONEscape(Source: TTextWriter);

begin

  if Source.fTotalFileSize=0 then

    AddJSONEscape(Source.fTempBuf,Source.B-Source.fTempBuf+1) else

    AddJSONEscape(Pointer(Source.Text),0);

end;



procedure TTextWriter.AddNoJSONEscape(Source: TTextWriter);

begin

  if Source.fTotalFileSize=0 then

    AddNoJSONEscape(Source.fTempBuf,Source.B-Source.fTempBuf+1) else

    AddNoJSONEscapeUTF8(Source.Text);

end;



procedure TTextWriter.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.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.RegisterCustomJSONSerializerFindParser(

  aTypeInfo: pointer; aAddIfNotExisting: boolean=false): TJSONRecordAbstract;

var ndx: integer;

begin

  result := nil;

  if aTypeInfo=nil then

    exit;

  case PTypeKind(aTypeInfo)^ of

  tkRecord{$ifdef FPC},tkObject{$endif}:

    ndx := GlobalJSONCustomParsers.RecordSearch(aTypeInfo,aAddIfNotExisting);

  tkDynArray:

    ndx := GlobalJSONCustomParsers.DynArraySearch(aTypeInfo,nil,aAddIfNotExisting);

  else

    exit;

  end;

  if ndx>=0 then

    result := GlobalJSONCustomParsers.fParser[ndx].RecordCustomParser;

end;



class procedure TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType(

  aTypeInfo: pointer; aTypeName: RawUTF8='');

begin

  if aTypeName='' then

    TypeInfoToName(aTypeInfo,aTypeName);

  GlobalCustomJSONSerializerFromTextSimpleType.AddObjectIfNotExisting(aTypeName,aTypeInfo);

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;



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,tkRecordTypeOrSet);

  if (self=nil) or (info=nil) then

    raise ESynException.CreateUTF8('Invalid %.AddVoidRecordJSON(%)',[self,TypeInfo]);

  SetLength(tmp,info^.recSize {$ifdef FPC}and $7FFFFFFF{$endif});

  AddRecordJSON(tmp[0],TypeInfo);

end;



{$ifndef NOVARIANTS}

procedure TTextWriter.AddVariant(const Value: variant; Escape: TTextWriterKind);

var CustomVariantType: TCustomVariantType;

begin

  with TVarData(Value) do

  case VType of

  varEmpty,

  varNull:     AddShort('null');

  varSmallint: Add(VSmallint);

  varShortInt: Add(VShortInt);

  varByte:     AddU(VByte);

  varWord:     AddU(VWord);

  varLongWord: AddU(VLongWord);

  varInteger:  Add(VInteger);

  varInt64:    Add(VInt64);

  varWord64:   Add(VInt64);

  varSingle:   AddSingle(VSingle);

  varDouble:   AddDouble(VDouble);

  varDate:     AddDateTime(@VDate,'T','"');

  varCurrency: AddCurr64(VInt64);

  varBoolean:  Add(VBoolean);

  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(VAny,length(RawUTF8(VAny)),Escape);

    {$endif}

    if Escape=twJSONEscape then

      Add('"');

  end;

  varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: begin

    if Escape=twJSONEscape then

      Add('"');

    AddW(VAny,0,Escape);

    if Escape=twJSONEscape then

      Add('"');

  end;

  else

  if VType=varVariant or varByRef then

    AddVariant(PVariant(VPointer)^,Escape) else

  if VType=varByRef or varString then begin

    if Escape=twJSONEscape then

      Add('"');

    {$ifdef HASCODEPAGE}

    AddAnyAnsiString(PRawByteString(VAny)^,Escape);

    {$else}  // VString is expected to be a RawUTF8

    Add(PPointer(VAny)^,length(PRawUTF8(VAny)^),Escape);

    {$endif}

    if Escape=twJSONEscape then

      Add('"');

  end else

  if {$ifdef HASVARUSTRING}(VType=varByRef or varUString) or {$endif}

     (VType=varByRef or varOleStr) then begin

    if Escape=twJSONEscape then

      Add('"');

    AddW(PPointer(VAny)^,0,Escape);

    if Escape=twJSONEscape then

      Add('"');

  end else

  if FindCustomVariantType(VType,CustomVariantType) and

     CustomVariantType.InheritsFrom(TSynInvokeableVariantType) then

    TSynInvokeableVariantType(CustomVariantType).ToJson(self,Value,Escape) else

    raise ESynException.CreateUTF8('%.AddVariant(VType=%)',[self,VType]);

  end;

end;

{$endif NOVARIANTS}



procedure TTextWriter.AddDynArrayJSON(aTypeInfo: pointer; const aValue);

var DynArray: TDynArray;

begin

  DynArray.Init(aTypeInfo,pointer(@aValue)^);

  AddDynArrayJSON(DynArray);

end;



{$ifdef UNDIRECTDYNARRAY}

procedure TTextWriter.AddDynArrayJSON(const aDynArray: TDynArrayHashed);

begin

  AddDynArrayJson(aDynArray.InternalDynArray);

end;

{$endif}



procedure TTextWriter.AddDynArrayJSONAsString(aTypeInfo: pointer; var aValue);

begin

  Add('"');

  InternalJSONWriter.AddDynArrayJSON(aTypeInfo,aValue);

  AddJSONEscape(fInternalJSONWriter);

  Add('"');

end;



procedure TTextWriter.AddObjArrayJSON(const aObjArray;

  Options: TTextWriterWriteObjectOptions);

var i: integer;

    a: TObjectDynArray absolute aObjArray;

begin

  Add('[');

  for i := 0 to length(a)-1 do begin

    WriteObject(a[i],Options);

    Add(',');

  end;

  CancelLastComma;

  Add(']');

end;



procedure TTextWriter.AddTypedJSON(aTypeInfo: pointer; const aValue;

  EnumSetsAsText,FullSetsAsStar: boolean);

var max, i: Integer;

    PS: PShortString;

begin

  case PTypeKind(aTypeInfo)^ of

    tkClass:

      WriteObject(TObject(aValue),[woFullExpand]);

    tkEnumeration:

      if EnumSetsAsText then begin

        Add('"');

        PS := GetEnumName(aTypeInfo,byte(aValue));

        if twoTrimLeftEnumSets in fCustomOptions then

          AddTrimLeftLowerCase(PS) else

          AddShort(PS^);

        Add('"');

      end else

        AddU(byte(aValue));

    tkSet:

      if GetSetInfo(aTypeInfo,max,PS) then

        if EnumSetsAsText then begin

          Add('[');

          if FullSetsAsStar and GetAllBits(cardinal(aValue),max+1) then

            AddShort('"*"') else begin

            for i := 0 to max do begin

              if GetBit(aValue,i) then begin

                Add('"');

                if twoTrimLeftEnumSets in fCustomOptions then

                  AddTrimLeftLowerCase(PS) else

                  AddShort(PS^);

                Add('"',',');

              end;

              inc(PByte(PS),ord(PS^[0])+1); // next short string

            end;

            CancelLastComma;

          end;

          Add(']');

        end else

        if max<8 then

          AddU(byte(aValue)) else

        if max<16 then

          AddU(word(aValue)) else

        if max<32 then

          AddU(cardinal(aValue)) else

          Add(Int64(aValue))

      else AddShort('null');

    tkRecord{$ifdef FPC},tkObject{$endif}:

      AddRecordJSON(aValue,aTypeInfo);

    tkDynArray:

      AddDynArrayJSON(DynArray(aTypeInfo,(@aValue)^));

{$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;

    ValueLen: integer;

begin

  result := nil;

  if JSON=nil then

    exit;

  if JSON^ in [#1..' '] then repeat inc(JSON) until not(JSON^ in [#1..' ']);

  case JSON^ of

  '[': begin // array

    repeat inc(JSON) until not(JSON^ in [#1..' ']);

    if JSON^=']' then begin

      Add('[');

      inc(JSON);

    end else begin

      if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then

        AddCRAndIndent;

      inc(fHumanReadableLevel);

      Add('[');

      repeat

        if JSON=nil then

          exit;

        if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then

          AddCRAndIndent;

        JSON := AddJSONReformat(JSON,Format,@objEnd);

        if objEnd=']' then

          break;

        Add(objEnd);

      until false;

      dec(fHumanReadableLevel);

      if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then

        AddCRAndIndent;

    end;

    Add(']');

  end;

  '{': begin // object

    repeat inc(JSON) until not(JSON^ in [#1..' ']);

    Add('{');

    inc(fHumanReadableLevel);

    if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then

      AddCRAndIndent;

    if JSON^='}' then

      repeat inc(JSON) until not(JSON^ in [#1..' ']) else

    repeat

      Name := GetJSONPropName(JSON);

      if Name=nil then

        exit;

      if (Format in [jsonUnquotedPropName,jsonUnquotedPropNameCompact]) and

         JsonPropNameValid(Name) then

        AddNoJSONEscape(Name,StrLen(Name)) else begin

        Add('"');

        AddJSONEscape(Name);

        Add('"');

      end;

      if Format in [jsonCompact,jsonUnquotedPropNameCompact] then

        Add(':') else

        Add(':',' ');

      if JSON^ in [#1..' '] then repeat inc(JSON) until not(JSON^ in [#1..' ']);

      JSON := AddJSONReformat(JSON,Format,@objEnd);

      if objEnd='}' then

        break;

      Add(objEnd);

      if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then

        AddCRAndIndent;

    until false;

    dec(fHumanReadableLevel);

      if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then

      AddCRAndIndent;

    Add('}');

  end;

  '"': begin // string

    Value := JSON;

    JSON := GotoEndOfJSONString(JSON);

    if JSON^<>'"' then

      exit;

    inc(JSON);

    AddNoJSONEscape(Value,JSON-Value);

  end;

  else begin // numeric or true/false/null

    Value := GetJSONField(JSON,result,nil,EndOfObject); // let wasString=nil

    if Value=nil then

      AddShort('null') else begin

      ValueLen := StrLen(Value);

      while (ValueLen>0) and (Value[ValueLen-1]<=' ') do dec(ValueLen);

      AddNoJSONEscape(Value,ValueLen);

    end;

    exit;

  end;

  end;

  if JSON<>nil then begin

    if JSON^ in [#1..' '] then repeat inc(JSON) until not(JSON^ in [#1..' ']);

    if EndOfObject<>nil then

      EndOfObject^ := JSON^;

    if JSON^<>#0 then

      repeat inc(JSON) until not(JSON^ in [#1..' ']);

  end;

  result := JSON;

end;



function TTextWriter.AddJSONToXML(JSON: PUTF8Char; ArrayName: PUTF8Char=nil;

  EndOfObject: PUTF8Char=nil): PUTF8Char;

var objEnd: AnsiChar;

    Name,Value: PUTF8Char;

    n,c: integer;

begin

  result := nil;

  if JSON=nil then

    exit;

  if JSON^ in [#1..' '] then repeat inc(JSON) until not(JSON^ in [#1..' ']);

  case JSON^ of

  '[': begin

    repeat inc(JSON) until not(JSON^ in [#1..' ']);

    if JSON^=']' then

      JSON := GotoNextNotSpace(JSON+1) else begin

      n := 0;

      repeat

        if JSON=nil then

          exit;

        Add('<');

        if ArrayName=nil then

          Add(n) else

          AddXmlEscape(ArrayName);

        Add('>');

        JSON := AddJSONToXML(JSON,nil,@objEnd);

        Add('<','/');

        if ArrayName=nil then

          Add(n) else

          AddXmlEscape(ArrayName);

        Add('>');

        inc(n);

      until objEnd=']';

    end;

  end;

  '{': begin

    repeat inc(JSON) until not(JSON^ in [#1..' ']);

    if JSON^='}' then

      repeat inc(JSON) until not(JSON^ in [#1..' ']) else

      repeat

        Name := GetJSONPropName(JSON);

        if Name=nil then

          exit;

        if JSON^ in [#1..' '] then repeat inc(JSON) until not(JSON^ in [#1..' ']);

        if JSON^='[' then // arrays are written as list of items, without root

          JSON := AddJSONToXML(JSON,Name,@objEnd) else begin

          Add('<');

          AddXmlEscape(Name);

          Add('>');

          JSON := AddJSONToXML(JSON,Name,@objEnd);

          Add('<','/');

          AddXmlEscape(Name);

          Add('>');

        end;

      until objEnd='}';

  end;

  else begin

    Value := GetJSONField(JSON,result,nil,EndOfObject); // let wasString=nil

    if Value=nil then

      AddShort('null') else begin

      c := PInteger(Value)^ and $ffffff;

      if (c=JSON_BASE64_MAGIC) or (c=JSON_SQLDATE_MAGIC) then

        inc(Value,3); // just ignore the Magic codepoint encoded as UTF-8

      AddXmlEscape(Value);

    end;

    exit;

  end;

  end;

  if JSON<>nil then begin

    if JSON^ in [#1..' '] then repeat inc(JSON) until not(JSON^ in [#1..' ']);

    if EndOfObject<>nil then

      EndOfObject^ := JSON^;

    if JSON^<>#0 then

      repeat inc(JSON) until not(JSON^ in [#1..' ']);

  end;

  result := JSON;

end;



procedure TTextWriter.AddDynArrayJSON(const aDynArray: TDynArray);

var i,n: integer;

    P: Pointer;

    T: TDynArrayKind;

    tmp: RawByteString;

    customWriter: TDynArrayJSONCustomWriter;

    customParser: TJSONRecordAbstract;

    Options: TJSONCustomParserSerializationOptions;

    NestedDynArray: TDynArray;

begin // code below must match TDynArray.LoadFromJSON

  n := aDynArray.Count-1;

  if n<0 then begin

    Add('[',']');

    exit;

  end;

  if GlobalJSONCustomParsers.DynArraySearch(

      aDynArray.ArrayType,aDynArray.ElemType,customWriter,@customParser) then

    T := djCustom else

    T := aDynArray.ToKnownType;

  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

        NestedDynArray.Init(aDynArray.ElemType,P^);

        AddDynArrayJSON(NestedDynArray);

        Add(',');

        inc(PtrUInt(P),aDynArray.ElemSize);

      end;

    end else begin

      tmp := aDynArray.SaveTo;

      WrBase64(pointer(tmp),length(tmp),true); // magic=true

    end;

  djCustom: begin

      if customParser=nil then

        byte(Options) := 0 else

        Options := customParser.Options;

      if soWriteHumanReadable in Options then

        Inc(fHumanReadableLevel);

      for i := 0 to n do begin

        customWriter(self,P^);

        Add(',');

        inc(PtrUInt(P),aDynArray.ElemSize);

      end;

      if soWriteHumanReadable in Options then begin

        dec(fHumanReadableLevel);

        CancelLastComma;

        AddCRAndIndent;

      end;

    end;

  {$ifndef NOVARIANTS}

  djVariant:

    for i := 0 to n do begin

      AddVariant(PVariantArray(P)^[i],twJSONEscape);

      Add(',');

    end;

  {$endif}

  djRawByteString:

    for i := 0 to n do begin

      WrBase64(PPointerArray(P)^[i],Length(PRawByteStringArray(P)^[i]),true);

      Add(',');

    end;

  djTimeLog..djString,djWideString..djInterface: // add textual JSON content

    for i := 0 to n do begin

      Add('"');

      case T of

      djTimeLog:  AddTimeLog(@PInt64Array(P)^[i]);

      djDateTime: AddDateTime(@PDoubleArray(P)^[i]);

      djRawUTF8:  AddJSONEscape(PPointerArray(P)^[i]);

      djWideString, djSynUnicode: AddJSONEscapeW(PPointerArray(P)^[i]);

      djWinAnsi:  AddAnyAnsiString(PRawByteStringArray(P)^[i],twJSONEscape,CODEPAGE_US);

      djString:

        {$ifdef UNICODE}

        AddJSONEscapeW(PPointerArray(P)^[i]);

        {$else}

        AddAnyAnsiString(PRawByteStringArray(P)^[i],twJSONEscape,0);

        {$endif}

      djInterface: AddPointer(PPtrIntArray(P)^[i]);

      end;

      Add('"',',');

    end;

  else // numerical JSON

    for i := 0 to n do begin

      case T of

      djBoolean:  Add(PBooleanArray(P)^[i]);

      djByte:     AddU(PByteArray(P)^[i]);

      djWord:     AddU(PWordArray(P)^[i]);

      djInteger:  Add(PIntegerArray(P)^[i]);

      djCardinal: AddU(PCardinalArray(P)^[i]);

      djSingle:   AddSingle(PSingleArray(P)^[i]);

      djInt64:    Add(PInt64Array(P)^[i]);

      djDouble:   AddDouble(PDoubleArray(P)^[i]);

      djCurrency: AddCurr64(PInt64Array(P)^[i]);

      end;

      Add(',');

    end;

    end;

  CancelLastComma;

  Add(']');

end;



procedure TTextWriter.Add(const Format: RawUTF8; const Values: array of const;

  Escape: TTextWriterKind=twNone);

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;

      13: AddCR;

      ord('%'): break;

      {$ifdef OLDTEXTWRITERFORMAT}

      164: AddCR; // ¤ -> add CR,LF

      167: if B^=',' then dec(B); // §

      ord('|'): begin

        inc(F); // |% -> %

        goto write;

      end;

      ord('$'),163,181: // $,£,µ

        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);

    {$ifdef OLDTEXTWRITERFORMAT}

    ord('$'): with Values[ValuesIndex] do

           if Vtype=vtInteger then Add2(VInteger);

    163: with Values[ValuesIndex] do // £

           if Vtype=vtInteger then Add4(VInteger);

    181: with Values[ValuesIndex] do // µ

           if Vtype=vtInteger then Add3(VInteger);

    {$endif}

    end;

    inc(F);

    inc(ValuesIndex);

  until false;

end;



procedure TTextWriter.AddLine(const Text: shortstring);

begin

  if BEnd-B<=ord(Text[0])+2 then

    FlushToStream;

  inc(B);

  MoveFast(Text[1],B[0],ord(Text[0]));

  inc(B,ord(Text[0]));

  PWord(B)^ := 13+10 shl 8; // CR + LF

  inc(B);

end;



procedure TTextWriter.AddPointer(P: PtrUInt);

  procedure Pointer4ToHex(B: PWordArray; P: PtrUInt);

  begin

    B[3] := TwoDigitsHexWB[ToByte(P)]; P := P shr 8;

    B[2] := TwoDigitsHexWB[ToByte(P)]; P := P shr 8;

    B[1] := TwoDigitsHexWB[ToByte(P)]; P := P shr 8;

    B[0] := TwoDigitsHexWB[P];

  end;

begin

  if BEnd-B<=sizeof(P)*2 then

    FlushToStream;

{$ifdef CPU64}

  if P and $ffffffff00000000<>0 then begin

    BinToHexDisplay(@P,PAnsiChar(B+1),8);

    inc(B,16);

    exit;

  end;

  // truncate to 8 hexa chars for most heap-allocated pointers

{$endif}

  Pointer4ToHex(@B[1],P);

  inc(B,8);

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.AddBinToHex(Bin: Pointer; BinBytes: integer);

var ChunkBytes: integer;

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<ChunkBytes then

      ChunkBytes := BinBytes;

    // add hexa characters

    SynCommons.BinToHex(PAnsiChar(Bin),PAnsiChar(B),ChunkBytes);

    inc(B,ChunkBytes*2);

    inc(PByte(Bin),ChunkBytes);

    dec(BinBytes,ChunkBytes);

    if BinBytes=0 then break;

    // Flush writes B-buf+1 -> special one below:

    inc(fTotalFileSize,fStream.Write(fTempBuf^,B-fTempBuf));

    B := fTempBuf;

  until false;

  dec(B); // allow CancelLastChar

end;



procedure TTextWriter.AddQuotedStr(Text: PUTF8Char; Quote: AnsiChar;

  TextLen: integer=0);

var BMax: PUTF8Char;

begin

  BMax := BEnd-3;

  if B>=BMax then begin

    FlushToStream;

    BMax := BEnd-3;

  end;

  B[1] := Quote;

  inc(B);

  if Text<>nil then

    repeat

      if B<BMax then begin

        if Text^=#0 then

          break;

        if TextLen>0 then begin

          if TextLen=3 then begin

            B[1] := '.'; // indicates truncated

            B[2] := '.';

            B[3] := '.';

            inc(B,3);

            break;

          end else

            dec(TextLen);

        end;

        if Text^<>Quote then begin

          B[1] := Text^;

          inc(Text);

          inc(B);

        end else begin

          B[1] := Quote;

          B[2] := Quote;

          inc(B,2);

          inc(Text);

        end;

      end else begin

        FlushToStream;

        BMax := BEnd-2;

      end;

    until false;

  B[1] := Quote;

  inc(B);

end;



procedure TTextWriter.AddHtmlEscape(Text: PUTF8Char; Fmt: TTextWriterHTMLFormat);

var i,beg: PtrInt;

begin

  if Text=nil then

    exit;

  i := 0;

  repeat

    beg := i;

    case Fmt of

    hfAnyWhere:

      while true do

        if Text[i] in [#0,'&','"','<','>'] then

          break else

          inc(i);

    hfOutsideAttributes:

      while true do

        if Text[i] in [#0,'&','<','>'] then

          break else

          inc(i);

    hfWithinAttributes:

      while true do

        if Text[i] in [#0,'&','"'] then

          break else

          inc(i);

    end;

    AddNoJSONEscape(Text+beg,i-beg);

    repeat

      case Text[i] of

      #0: exit;

      '<': AddShort('&lt;');

      '>': AddShort('&gt;');

      '&': AddShort('&amp;');

      '"': AddShort('&quot;');

      else break;

      end;

      inc(i);

    until false;

  until false;

end;



procedure TTextWriter.AddHtmlEscape(Text: PUTF8Char; TextLen: integer;

  Fmt: TTextWriterHTMLFormat);

var i,beg: PtrInt;

begin

  if (Text=nil) or (TextLen<=0) then

    exit;

  i := 0;

  repeat

    beg := i;

    case Fmt of

    hfAnyWhere:

      while i<TextLen do

        if Text[i] in [#0,'&','"','<','>'] then

          break else

          inc(i);

    hfOutsideAttributes:

      while i<TextLen do

        if Text[i] in [#0,'&','<','>'] then

          break else

          inc(i);

    hfWithinAttributes:

      while i<TextLen do

        if Text[i] in [#0,'&','"'] then

          break else

          inc(i);

    end;

    AddNoJSONEscape(Text+beg,i-beg);

    repeat

      if i=TextLen then

        exit;

      case Text[i] of

      #0: exit;

      '<': AddShort('&lt;');

      '>': AddShort('&gt;');

      '&': AddShort('&amp;');

      '"': AddShort('&quot;');

      else break;

      end;

      inc(i);

    until false;

  until false;

end;



procedure TTextWriter.AddHtmlEscapeString(const Text: string; Fmt: TTextWriterHTMLFormat);

begin

  AddHtmlEscape(pointer(StringToUTF8(Text)),Fmt);

end;



procedure TTextWriter.AddHtmlEscapeUTF8(const Text: RawUTF8; Fmt: TTextWriterHTMLFormat);

begin

  AddHtmlEscape(pointer(Text),length(Text),Fmt);

end;



procedure TTextWriter.AddHtmlEscapeWiki(P: PUTF8Char);

var B: PUTF8Char;

    bold,italic: boolean;

  procedure Toggle(var value: Boolean; HtmlChar: AnsiChar);

  begin

    Add('<');

    if value then

      Add('/');

    Add(HtmlChar,'>');

    value := not value;

  end;

  procedure EndOfParagraph;

  begin

    if bold then

      Toggle(bold,'B');

    if italic then

      Toggle(italic,'I');

    AddShort('</p>');

  end;

begin

  bold := false;

  italic := false;

  AddShort('<p>');

  if P<>nil then

    repeat

      B := P;

      while not (ord(P^) in [0,13,10,ord('*'),ord('+')]) do

        if (P^='h') and IdemPChar(P+1,'TTP://') then

          break else

          inc(P);

      AddHtmlEscape(B,P-B,hfOutsideAttributes);

      case ord(P^) of

      0: break;

      10,13: begin

        EndOfParagraph;

        AddShort('<p>');

        while P[1] in [#10,#13] do inc(P);

      end;

      ord('*'):

        Toggle(italic,'I');

      ord('+'):

        Toggle(bold,'B');

      ord('h'): begin

        B := P;

        while P^>' ' do inc(P);

        AddShort('<a href=');

        AddHtmlEscape(B,P-B);

        Add('>');

        AddHtmlEscape(B,P-B);

        AddShort('</a>');

        continue;

      end;

      end;

      inc(P);

    until P^=#0;

  EndOfParagraph;

end;



procedure TTextWriter.AddXmlEscape(Text: PUTF8Char);

const XML_ESCAPE: set of byte = [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. -> // '&#x09;'

        AddShort('&#x');

        AddByteToHex(ord(Text[i]));

        Add(';');

      end;

      '<': AddShort('&lt;');

      '>': AddShort('&gt;');

      '&': AddShort('&amp;');

      '"': AddShort('&quot;');

      '''': AddShort('&apos;');

      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)=Value);

  inc(B,3);

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: integer);

var i: integer;

begin

  if (P<>nil) and (Len>0) then begin

    inc(B); // allow CancelLastChar

    repeat

      i := BEnd-B+1; // guess biggest size to be added into buf^ at once

      if Len<i then

        i := Len;

      // add UTF-8 bytes

      MoveFast(P^,B^,i);

      inc(B,i);

      if i=Len then

        break;

      inc(PByte(P),i);

      dec(Len,i);

      // FlushInc writes B-buf+1 -> special one below:

      inc(fTotalFileSize,fStream.Write(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)<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.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 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 PInteger(s)^ and $ffffff=JSON_BASE64_MAGIC then begin

    AddNoJSONEscape(pointer(s),L); // identified as a BLOB content

    exit;

  end;

  if CodePage<0 then

    {$ifdef HASCODEPAGE}

    CodePage := StringCodePage(s);

    {$else}

    CodePage := 0; // TSynAnsiConvert.Engine(0)=CurrentAnsiConvert

    {$endif}

  AddAnyAnsiBuffer(pointer(s),L,Escape,CodePage);

end;



procedure TTextWriter.AddAnyAnsiBuffer(P: PAnsiChar; Len: integer;

  Escape: TTextWriterKind; CodePage: Integer);

var B: PUTF8Char;

begin

  if Len>0 then

  case CodePage of

  CP_UTF8, CP_RAWBYTESTRING:

    Add(PUTF8Char(P),Len,Escape);  // direct write of RawUTF8/RawByteString content

  CP_UTF16:

    AddW(PWord(P),0,Escape); // direct write of UTF-16 content

  CP_SQLRAWBLOB: begin

    AddNoJSONEscape(@PByteArray(@JSON_BASE64_MAGIC_QUOTE_VAR)[1],3);

    WrBase64(P,Len,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);

    Add(B,P-B,Escape);

    if Len=0 then

      exit;

    // rely on explicit conversion for all remaining ASCII characters

    TSynAnsiConvert.Engine(CodePage).InternalAppendUTF8(P,Len,self,Escape);

  end;

  end;

end;



const // see http://www.ietf.org/rfc/rfc4627.txt

  JSON_ESCAPE: set of byte = [0..31,ord('\'),ord('"')];



function NeedsJsonEscape(const Text: RawUTF8): boolean;

var i: integer;

begin

  result := true;

  for i := 1 to length(Text) do

    if byte(Text[i]) in JSON_ESCAPE then

      exit;

  result := false;

end;



procedure TTextWriter.InternalAddFixedAnsi(Source: PAnsiChar; SourceChars: Cardinal;

  const AnsiToWide: TWordDynArray; Escape: TTextWriterKind);

var c: cardinal;

begin

  while SourceChars>0 do begin

    c := byte(Source^);

    if c<=$7F then begin

      if B>=BEnd then

        FlushToStream;

      case Escape of

      twNone: begin

        inc(B);

        B^ := AnsiChar(c);

      end;

      twJSONEscape:

        if c in JSON_ESCAPE then

          AddJsonEscape(Source,1) else begin

          inc(B);

          B^ := AnsiChar(c);

        end;

      twOnSameLine: begin

        inc(B);

        if c<32 then

          B^ := ' ' else

          B^ := AnsiChar(c);

      end;

      end

    end else begin // no surrogate is expected in TSynAnsiFixedWidth charsets

      if BEnd-B<=3 then

        FlushToStream;

      c := AnsiToWide[c]; // convert FixedAnsi char into Unicode char

      if c>$7ff then begin

        B[1] := AnsiChar($E0 or (c shr 12));

        B[2] := AnsiChar($80 or ((c shr 6) and $3F));

        B[3] := AnsiChar($80 or (c and $3F));

        inc(B,3);

      end else begin

        B[1] := AnsiChar($C0 or (c shr 6));

        B[2] := AnsiChar($80 or (c and $3F));

        inc(B,2);

      end;

    end;

    dec(SourceChars);

    inc(Source);

  end;

end;



procedure TTextWriter.AddOnSameLine(P: PUTF8Char);

begin

  if P<>nil then

    while P^<>#0 do begin

      if B>=BEnd then

        FlushToStream;

      if P^<' ' then

        B[1] := ' ' else

        B[1] := P^;

      inc(P);

      inc(B);

    end;

end;



procedure TTextWriter.AddOnSameLine(P: PUTF8Char; Len: PtrInt);

var i: PtrInt;

begin

  if P<>nil then

    for i := 0 to Len-1 do begin

      if B>=BEnd then

        FlushToStream;

      if P[i]<' ' then

        B[1] := ' ' else

        B[1] := P[i];

      inc(B);

    end;

end;



procedure TTextWriter.AddOnSameLineW(P: PWord; Len: PtrInt);

var PEnd: PtrUInt;

begin

  if P=nil then exit;

  if Len=0 then

    PEnd := 0 else

    PEnd := PtrUInt(P)+PtrUInt(Len)*sizeof(WideChar);

  while (Len=0) or (PtrUInt(P)<PEnd) do begin

    if BEnd-B<=7 then

      FlushToStream;

    // escape chars, so that all content will stay on the same text line

    case P^ of

      0: break;

      1..32: begin

        B[1] := ' ';

        inc(B);

        inc(P);

      end;

      33..126: begin

        B[1] := AnsiChar(ord(P^)); // direct store 7 bits ASCII

        inc(B);

        inc(P);

      end;

      else // characters higher than #126 -> UTF-8 encode

        inc(B,UTF16CharToUtf8(B+1,P));

    end;

  end;

end;



procedure TTextWriter.AddJSONEscape(P: Pointer; Len: PtrInt);

var i,c: integer;

label noesc;

begin

  if P=nil then

    exit;

  if Len=0 then

    Len := MaxInt;

  i := 0;

  while i<Len do begin

    if not(PByteArray(P)[i] in JSON_ESCAPE) then begin

noesc:c := i;

      repeat

        inc(i);

      until (i>=Len) or (PByteArray(P)[i] in JSON_ESCAPE);

      inc(PByte(P),c);

      dec(i,c);

      dec(Len,c);

      if BEnd-B<=i then

        AddNoJSONEscape(P,i) else begin

        MoveFast(P^,B[1],i);

        inc(B,i);

      end;

    end;

    while i<Len do begin

      c := PByteArray(P)[i];

      case c of

      0:  exit;

      8:  c := ord('\')+ord('b')shl 8;

      9:  c := ord('\')+ord('t')shl 8;

      10: c := ord('\')+ord('n')shl 8;

      12: c := ord('\')+ord('f')shl 8;

      13: c := ord('\')+ord('r')shl 8;

      ord('\'): c := ord('\')+ord('\')shl 8;

      ord('"'): c := ord('\')+ord('"')shl 8;

      1..7,11,14..31: begin // characters below ' ', #7 e.g. -> // 'u0007'

        AddShort('\u00');

        c := TwoDigitsHexWB[c];

      end;

      else goto noesc;

      end;

      if BEnd-B<=1 then

        FlushToStream;

      PWord(B+1)^ := c;

      inc(B,2);

      inc(i);

    end;

  end;

end;



procedure TTextWriter.AddJSONEscapeW(P: PWord; Len: PtrInt);

var i,c: PtrInt;

begin

  if P=nil then

    exit;

  if Len=0 then

    Len := MaxInt;

  i := 0;

  while i<Len do begin

    c := i;

    if not(PWordArray(P)[i] in JSON_ESCAPE) then begin

      repeat

        inc(i);

      until (i>=Len) or (PWordArray(P)[i] in JSON_ESCAPE);

      AddNoJSONEscapeW(@PWordArray(P)[c],i-c);

    end;

    while i<Len do begin

      c := PWordArray(P)[i];

      case c of

      0:  exit;

      8:  Add('\','b');

      9:  Add('\','t');

      10: Add('\','n');

      12: Add('\','f');

      13: Add('\','r');

      ord('\'),ord('"'): Add('\',AnsiChar(c));

      1..7,11,14..31: begin // characters below ' ', #7 e.g. -> // 'u0007'

        AddShort('\u00');

        AddByteToHex(c);

      end;

      else break;

      end;

      inc(i);

    end;

  end;

end;



procedure TTextWriter.AddJSONEscape(const V: TVarRec);

begin

  with V do

  case VType of

    vtPointer: AddShort('null');

    vtString, vtAnsiString,{$ifdef HASVARUSTRING}vtUnicodeString,{$endif}

    vtPChar, vtChar, vtWideChar, vtWideString, vtClass: begin

      Add('"');

      case VType of

        vtString:     AddJSONEscape(@VString^[1],ord(VString^[0]));

        vtAnsiString: AddJSONEscape(pointer(RawUTF8(VAnsiString)));

        {$ifdef HASVARUSTRING}

        vtUnicodeString: AddJSONEscapeW(

          pointer(UnicodeString(VUnicodeString)),length(UnicodeString(VUnicodeString)));

        {$endif}

        vtPChar:      AddJSONEscape(VPChar);

        vtChar:       AddJSONEscape(@VChar,1);

        vtWideChar:   AddJSONEscapeW(@VWideChar,1);

        vtWideString: AddJSONEscapeW(VWideString);

        vtClass:      AddClassName(VClass);

      end;

      Add('"');

    end;

    vtBoolean:  Add(VBoolean);

    vtInteger:  Add(VInteger);

    vtInt64:    Add(VInt64^);

    vtExtended: Add(VExtended^,DOUBLE_PRECISION);

    vtCurrency: AddCurr64(VInt64^);

    vtObject:   WriteObject(VObject);

    {$ifndef NOVARIANTS}

    vtVariant:  AddVariant(VVariant^,twJSONEscape);

    {$endif}

  end;

end;



procedure TTextWriter.Add(const V: TVarRec; Escape: TTextWriterKind);

begin

  with V do

  case Vtype of

  vtInteger:      Add(VInteger);

  vtBoolean:      AddU(byte(VBoolean));

  vtChar:         Add(@VChar,1,Escape);

  vtExtended:     Add(VExtended^,DOUBLE_PRECISION);

  vtString:       Add(@VString^[1],ord(VString^[0]),Escape);

  vtInterface,

  vtPointer:      AddPointer(PtrUInt(VPointer));

  vtPChar:        Add(PUTF8Char(VPChar),Escape);

  vtObject:       WriteObject(VObject,[woFullExpand]);

  vtClass:        AddClassName(VClass);

  vtWideChar:

    AddW(@VWideChar,1,Escape);

  vtPWideChar:

    AddW(pointer(VPWideChar),StrLenW(VPWideChar),Escape);

  vtAnsiString:

    Add(VAnsiString,length(RawUTF8(VAnsiString)),Escape); // expect RawUTF8

  vtCurrency:

    AddCurr64(VInt64^);

  vtWideString:

    if VWideString<>nil then

      AddW(VWideString,length(WideString(VWideString)),Escape);

  vtInt64:

    Add(VInt64^);

  {$ifndef NOVARIANTS}

  vtVariant:

    AddVariant(VVariant^,Escape);

  {$endif}

  {$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);

begin

  AddVariant(_JsonFastFmt(Format,Args,Params),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<high(NameValuePairs) do begin

      inc(a);

      if VarRecAsChar(NameValuePairs[a])=ord(']') then

        break;

      WriteValue;

    end;

    CancelLastComma;

    Add(']');

  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;

    Add('}');

  end else

    AddJSONEscape(NameValuePairs[a]);

  end;

  Add(',');

end;

begin

  Add('{');

  a := 0;

  while a<high(NameValuePairs) do begin

    AddJSONEscape(NameValuePairs[a]);

    inc(a);

    Add(':');

    WriteValue;

    inc(a);

  end;

  CancelLastComma;

  Add('}');

end;



procedure TTextWriter.AddNoJSONEscapeString(const s: string);

begin

  if s<>'' then

    {$ifdef UNICODE}

    AddNoJSONEscapeW(pointer(s),length(s));

    {$else}

    AddAnsiString(s,twNone);

    {$endif}

end;



procedure TTextWriter.AddJSONEscapeString(const s: string);

begin

  if s<>'' then

    {$ifdef UNICODE}

    AddJSONEscapeW(pointer(s),Length(s));

    {$else}

    AddAnyAnsiString(s,twJSONEscape,0);

    {$endif}

end;



procedure TTextWriter.AddJSONEscapeAnsiString(const s: AnsiString);

begin

  AddAnyAnsiString(s,twJSONEscape,0);

end;



procedure TTextWriter.AddPropName(const PropName: ShortString);

begin

  if ord(PropName[0])=0 then

    exit;

  if BEnd-B<=ord(PropName[0])+3 then

    FlushToStream;

  if twoForceJSONExtended in CustomOptions then begin

    MoveFast(PropName[1],B[1],ord(PropName[0]));

    inc(B,ord(PropName[0])+1);

    B^ := ':';

  end else begin

    B[1] := '"';

    MoveFast(PropName[1],B[2],ord(PropName[0]));

    inc(B,ord(PropName[0])+2);

    PWord(B)^ := ord('"')+ord(':')shl 8;

    inc(B);

  end;

end;



procedure TTextWriter.AddFieldName(const FieldName: RawUTF8);

begin

  AddFieldName(Pointer(FieldName),length(FieldName));

end;



procedure TTextWriter.AddFieldName(FieldName: PUTF8Char; FieldNameLen: integer);

begin

  if BEnd-B<=FieldNameLen+3 then

    FlushToStream;

  B[1] := '"';

  MoveFast(FieldName^,B[2],FieldNameLen);

  inc(B,FieldNameLen+2);

  PWord(B)^ := ord('"')+ord(':')shl 8;

  inc(B);

end;



procedure TTextWriter.AddClassName(aClass: TClass);

begin

  if aClass<>nil then

    AddShort(PShortString(PPointer(PtrInt(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('(');

  AddPointer(PtrUInt(Instance));

  Add(')','"');

  if SepChar<>#0 then

    Add(SepChar);

end;



procedure TTextWriter.AddInstancePointer(Instance: TObject; SepChar: AnsiChar;

  IncludeUnitName: boolean);

begin

  AddShort(PShortString(PPointer(PPtrInt(Instance)^+vmtClassName)^)^);

  Add('(');

  AddPointer(PtrUInt(Instance));

  Add(')');

  if SepChar<>#0 then

    Add(SepChar);

end;



procedure TTextWriter.AddShort(const Text: ShortString);

begin

  if ord(Text[0])=0 then

    exit;

  if BEnd-B<=ord(Text[0]) then

    FlushToStream;

  MoveFast(Text[1],B[1],ord(Text[0]));

  inc(B,ord(Text[0]));

end;



procedure TTextWriter.AddQuotedStringAsJSON(const QuotedString: RawUTF8);

var L: integer;

    P,B: PUTF8Char;

    quote: AnsiChar;

begin

  L := length(QuotedString);

  if L>0 then begin

    quote := QuotedString[1];

    if (quote in ['''','"']) and (QuotedString[L]=quote) then begin

      Add('"');

      P := pointer(QuotedString);

      inc(P);

      repeat

        B := P;

        while P[0]<>quote do inc(P);

        if P[1]<>quote then

          break; // end quote

        inc(P);

        AddJSONEscape(B,P-B);

        inc(P); // ignore double quote

      until false;

      if P-B<>0 then

        AddJSONEscape(B,P-B);

      Add('"');

    end else

      AddNoJSONEscape(pointer(QuotedString),length(QuotedString));

  end;

end;



procedure TTextWriter.AddTrimLeftLowerCase(Text: PShortString);

var P: PAnsiChar;

    L: integer;

begin

  L := length(Text^);

  P := @Text^[1];

  while (L>0) and (P^ in ['a'..'z']) do begin

    inc(P);

    dec(L);

  end;

  if L=0 then

    AddShort(Text^) else

    AddNoJSONEscape(P,L);

end;



procedure TTextWriter.AddString(const Text: RawUTF8);

var L: integer;

begin

  if PtrInt(Text)=0 then

    exit;

  {$ifdef FPC}

  L := PStrRec(Pointer(PtrInt(Text)-STRRECSIZE))^.length;

  {$else}

  L := PInteger(PtrInt(Text)-sizeof(integer))^;

  {$endif}

  if L<fTempBufSize then begin

    if BEnd-B<=L then

      FlushToStream;

    MoveFast(pointer(Text)^,B[1],L);

    inc(B,L);

  end else

    AddNoJSONEscape(pointer(Text),L);

end;



procedure TTextWriter.AddStringCopy(const Text: RawUTF8; start,len: integer);

var L: integer;

begin

  if (len<=0) or (PtrInt(Text)=0) then

    exit;

  if start<0 then

    start := 0 else

    dec(start);

  {$ifdef FPC}

  L := PStrRec(Pointer(PtrInt(Text)-STRRECSIZE))^.length;

  {$else}

  L := PInteger(PtrInt(Text)-sizeof(integer))^;

  {$endif}

  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: integer;

begin

  for i := 0 to high(Text) do

    AddString(Text[i]);

end;



procedure TTextWriter.AddStrings(const Text: RawUTF8; count: integer);

var i,L: integer;

begin

  L := length(Text);

  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.CancelLastChar;

begin

  dec(B);

end;



function TTextWriter.LastChar: AnsiChar;

begin

  result := B^;

end;



procedure TTextWriter.CancelLastChar(aCharToCancel: AnsiChar);

begin

  if B^=aCharToCancel then

    dec(B);

end;



function TTextWriter.PendingBytes: PtrUInt;

begin

  result := B-fTempBuf;

end;



procedure TTextWriter.CancelLastComma;

begin

  if B^=',' then

    dec(B);

end;



constructor TTextWriter.Create(aStream: TStream; aBufSize: integer);

begin

  SetStream(aStream);

  if aBufSize<256 then

    aBufSize := 256;

  fTempBufSize := aBufSize;

  GetMem(fTempBuf,aBufSize);

  B := fTempBuf-1; // Add() methods will append at B+1

  BEnd := fTempBuf+fTempBufSize-2;

  if DefaultTextWriterTrimEnum then

    Include(fCustomOptions,twoTrimLeftEnumSets);

end;



constructor TTextWriter.CreateOwnedStream(aBufSize: integer);

begin

  Create(TRawByteStringStream.Create,aBufSize);

  Include(fCustomOptions,twoStreamIsOwned);

end;



constructor TTextWriter.CreateOwnedFileStream(const aFileName: TFileName;

  aBufSize: integer);

begin

  DeleteFile(aFileName);

  Create(TFileStream.Create(aFileName,fmCreate),aBufSize);

  Include(fCustomOptions,twoStreamIsOwned);

end;



destructor TTextWriter.Destroy;

begin

  if twoStreamIsOwned in fCustomOptions then

    fStream.Free;

  FreeMem(fTempBuf);

  fInternalJSONWriter.Free;

  inherited;

end;



class procedure TTextWriter.SetDefaultJSONClass(aClass: TTextWriterClass);

begin

  DefaultTextWriterJSONClass := aClass;

end;



class procedure TTextWriter.SetDefaultEnumTrim(aShouldTrimEnumsAsText: boolean);

begin

  DefaultTextWriterTrimEnum := aShouldTrimEnumsAsText;

end;



procedure TTextWriter.SetStream(aStream: TStream);

begin

  if fStream<>nil then

    if twoStreamIsOwned in fCustomOptions then begin

      FreeAndNil(fStream);

      Exclude(fCustomOptions,twoStreamIsOwned);

    end;

  if aStream<>nil then begin

    fStream := aStream;

    fInitialStreamPosition := fStream.Seek(0,soFromCurrent);

    fTotalFileSize := fInitialStreamPosition;

  end;

end;



procedure TTextWriter.FlushToStream;

begin

  if fEchos<>nil then begin

    EchoFlush;

    fEchoStart := 0;

  end;

  inc(fTotalFileSize,fStream.Write(fTempBuf^,B-fTempBuf+1));

  if (not (twoFlushToStreamNoAutoResize in fCustomOptions)) and

     (fTempBufSize<49152) and

     (fTotalFileSize-fInitialStreamPosition>1 shl 18) then begin

    FreeMem(fTempBuf); // with big content (256KB) comes bigger buffer (64KB)

    fTempBufSize := 65536;

    GetMem(fTempBuf,65536);

    BEnd := fTempBuf+(65536-2);

  end;

  B := fTempBuf-1;

end;



function TTextWriter.GetEndOfLineCRLF: boolean;

begin

  result := twoEndOfLineCRLF in fCustomOptions;

end;



procedure TTextWriter.SetEndOfLineCRLF(aEndOfLineCRLF: boolean);

begin

  Include(fCustomOptions,twoEndOfLineCRLF);

end;    



function TTextWriter.GetLength: cardinal;

begin

  if self=nil then

    result := 0 else

    result := cardinal(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.Write(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);

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;

    end else

      SetRawUTF8(result,PAnsiChar(pointer(DataString))+fInitialStreamPosition,Len) else

  if fStream.InheritsFrom(TCustomMemoryStream) then

    with TCustomMemoryStream(fStream) do

    SetRawUTF8(result,PAnsiChar(Memory)+fInitialStreamPosition,Len) else begin

    FastNewRawUTF8(result,Len);

    fStream.Seek(fInitialStreamPosition,soBeginning);

    fStream.Read(pointer(result)^,Len);

  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,true);

end;



procedure TTextWriter.WrBase64(P: PAnsiChar; Len: cardinal; withMagic: boolean);

var trailing, main, n: cardinal;

begin

  if withMagic then

    if len<=0 then begin

      AddShort('null'); // JSON null is better than "" for BLOBs

      exit;

    end else

    AddNoJSONEscape(@JSON_BASE64_MAGIC_QUOTE_VAR,4);

  if len>0 then begin

    n := Len div 3;

    trailing := Len-n*3;

    dec(Len,trailing);

    if BEnd-B>integer(n+1) shl 2 then begin

      // will fit in available space in Buf -> fast in-buffer Base64 encoding

      n := Base64EncodeMain(@B[1],P,Len);

      inc(B,n*4);

      inc(P,n*3);

    end else begin

      // bigger than available space in Buf -> do it per chunk

      FlushToStream;

      while Len>0 do begin // length(buf) const -> so is ((length(buf)-4)shr2 )*3

        n := ((fTempBufSize-4)shr 2)*3;

        if Len<n then

          n := Len;

        main := Base64EncodeMain(PAnsiChar(fTempBuf),P,n);

        n := main*4;

        if n<cardinal(fTempBufSize)-4 then

          inc(B,n) else

          inc(fTotalFileSize,fStream.Write(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 TTextWriter.EchoAdd(const aEcho: TOnTextWriterEcho);

begin

  if self<>nil then

    if MultiEventAdd(fEchos,TMethod(aEcho)) then

      if fEchos<>nil then

        fEchoStart := B-fTempBuf+1; // ignore any previous buffer

end;



procedure TTextWriter.EchoRemove(const aEcho: TOnTextWriterEcho);

begin

  if self<>nil then

    MultiEventRemove(fEchos,TMethod(aEcho));

end;



function TTextWriter.EchoFlush: integer;

var L,LI: Integer;

    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); // faster append to fEchoBuf

  SetLength(fEchoBuf,LI+L);

  MoveFast(P^,PByteArray(fEchoBuf)[LI],L);

end;



procedure TTextWriter.EchoReset;

begin

  fEchoBuf := '';

end;





{ 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);

begin

  Create(aStream,Expand,withID,FieldBitsToIndex(Fields));

end;



constructor TJSONWriter.Create(aStream: TStream; Expand, withID: boolean;

  const Fields: TSQLFieldIndexDynArray);

begin

  if aStream=nil then

    CreateOwnedStream else

    inherited Create(aStream);

  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);

begin

  CancelLastComma; // cancel last ','

  Add(']');

  if not fExpand then begin

    if aKnownRowsCount=0 then begin

      AddShort(',"rowCount":');

      Add(aRowsCount);

    end;

    Add('}');

  end;

  Add(#10);

  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;





function JSONEncode(const NameValuePairs: array of const): RawUTF8;

begin

  if high(NameValuePairs)<1 then

    result := '{}' else // return void JSON object on error

    with DefaultTextWriterJSONClass.CreateOwnedStream do

    try

      AddJSONEscape(NameValuePairs);

      SetText(result);

    finally

      Free

    end;

end;



{$ifndef NOVARIANTS}

function JSONEncode(const Format: RawUTF8; const Args,Params: array of const): RawUTF8; overload;

begin

  with DefaultTextWriterJSONClass.CreateOwnedStream do

  try

    AddJSON(Format,Args,Params);

    SetText(result);

  finally

    Free

  end;

end;

{$endif}



function JSONEncodeArrayDouble(const Values: array of double): RawUTF8;

var W: TTextWriter;

begin

  W := DefaultTextWriterJSONClass.CreateOwnedStream;

  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;

begin

  W := DefaultTextWriterJSONClass.CreateOwnedStream;

  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;

begin

  W := DefaultTextWriterJSONClass.CreateOwnedStream;

  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);

begin

  if length(Values)=0 then

    if WithoutBraces then

      result := '' else

      result := '[]' else

    with DefaultTextWriterJSONClass.CreateOwnedStream 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);

begin

  if (SQLValue<>'') and (SQLValue[1] in ['''','"']) then

    // unescape SQL quoted string value into a valid JSON string

    with DefaultTextWriterJSONClass.CreateOwnedStream 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 JSONDecode(var JSON: RawUTF8;

  const Names: array of PUTF8Char; var Values: TPUtf8CharDynArray;

  HandleValuesAsObjectOrArray: Boolean=false);

begin

  JSONDecode(UniqueRawUTF8(JSON),Names,Values,HandleValuesAsObjectOrArray);

end;



function JSONDecode(P: PUTF8Char; const Names: array of PUTF8Char;

  var Values: TPUtf8CharDynArray; HandleValuesAsObjectOrArray: Boolean=false): PUTF8Char;

var n, i: PtrInt;

    Name, Value: PUTF8Char;

    EndOfObject: AnsiChar;

    NewValues: boolean;

begin

  result := nil;

  n := length(Names);

  NewValues := pointer(Values)=nil;

  SetLength(Values,n);

  if not NewValues then

    FillcharFast(Values[0],n*sizeof(PUTF8Char),0); // SetLength() could leave it not void

  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);

    if Name=nil then

      exit;  // invalid JSON content

    Value := GetJSONFieldOrObjectOrArray(P,nil,@EndOfObject,HandleValuesAsObjectOrArray);

    if not(EndOfObject in [',','}']) then

      exit; // invalid item separator

    for i := 0 to n do

      if StrIComp(Name,Names[i])=0 then begin

        Values[i] := Value;

        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;

    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);

    if Name=nil then

      exit;  // invalid JSON content

    Value := GetJSONFieldOrObjectOrArray(

      P,wasString,@EndOfObject,HandleValuesAsObjectOrArray);

    if not(EndOfObject in [',','}']) then

      exit; // invalid item separator

    if StrIComp(Name,pointer(aName))=0 then begin

      Result := RawUTF8(Value);

      exit;

    end;

  until (P=nil) or (EndOfObject='}');

end;



function JSONDecode(P: PUTF8Char; out Values: TNameValuePUTF8CharDynArray;

  HandleValuesAsObjectOrArray: Boolean=false): PUTF8Char;

var n: PtrInt;

    Name, Value: PUTF8Char;

    EndOfObject: AnsiChar;

begin

  result := nil;

  n := 0;

  if P<>nil then begin

    while P^<>'{' do

      if P^=#0 then

        exit else

        inc(P);

    inc(P); // jump {

    repeat

      Name := GetJSONPropName(P);

      if Name=nil then

        exit;  // invalid JSON content

      Value := GetJSONFieldOrObjectOrArray(P,nil,@EndOfObject,HandleValuesAsObjectOrArray);

      if not(EndOfObject in [',','}']) then

        exit; // invalid item separator

      if n=length(Values) then

        SetLength(Values,n+32);

      Values[n].Name := Name;

      Values[n].Value := Value;

      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^ in [#1..' '] 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 not(P^ in [#1..' ']);

  if ExpectNameField then begin

    if P^<>':' then

      exit; // invalid name field

  end else

    if not (P^ in ['}',',']) then

      exit; // invalid value field

  result := P; // return either ':' for name field, either '}',',' for value

end;



/// decode a JSON field into an UTF-8 encoded buffer, stored inplace of JSON data

function GetJSONField(P: PUTF8Char; out PDest: PUTF8Char;

  wasString: PBoolean=nil; EndOfObject: PUTF8Char=nil): PUTF8Char;

// this code is very fast

var D: PUTF8Char;

    b,c4,surrogate,j: integer;

label slash,num;

begin

  if wasString<>nil then

    wasString^ := false; // default is 'no string'

  PDest := nil; // PDest=nil indicates error or unexpected end (#0)

  result := nil;

  if P=nil then exit;

  if P^<=' ' then repeat inc(P); if P^=#0 then exit; until P^>' ';

  case P^ of

  'n':

    if (PInteger(P)^=NULL_LOW) and (P[4] in EndOfJSONValueField)  then begin

      result := nil; // null -> returns nil and wasString=false

      inc(P,3);

    end else

      exit; // PDest=nil to indicate error

  'f':

    if (PInteger(P+1)^=ord('a')+ord('l')shl 8+ord('s')shl 16+ord('e')shl 24) and

       (P[5] in EndOfJSONValueField) then begin

      result := P; // false -> returns 'false' and wasString=false

      inc(P,4);

    end else

      exit; // PDest=nil to indicate error

  't':

    if (PInteger(P)^=TRUE_LOW) and (P[4] in EndOfJSONValueField)  then begin

      result := P; // true -> returns 'true' and wasString=false

      inc(P,3);

    end else

      exit; // PDest=nil to indicate error

  '"': begin

    // '"string \"\\field"' -> 'string "\field'

    if wasString<>nil then

      wasString^ := true;

    inc(P);

    result := P;

    D := P;

    repeat // unescape P^ into U^ (cf. http://www.ietf.org/rfc/rfc4627.txt)

      case P^ of

      #0:  exit;  // leave PDest=nil for unexpected end

      '"': break; // end of string

      '\': goto slash;

      else begin

        D^ := P^; // 3 stages pipelined process of unescaped chars

        inc(P);

        inc(D);

        case P^ of

        #0:  exit;

        '"': break;

        '\': goto slash;

        else begin

          D^ := P^;

          inc(P);

          inc(D);

          case P^ of

          #0:  exit;

          '"': break;

          '\': goto slash;

          else begin

            D^ := P^;

            inc(P);

            inc(D);

            continue;

          end;

          end;

        end;

        end;

      end;

      end;

slash:inc(P);

      case P^ of // unescape JSON string

        #0: exit; // to avoid potential buffer overflow issue for \#0

        'b': D^ := #08;

        't': D^ := #09;

        'n': D^ := #$0a;

        'f': D^ := #$0c;

        'r': D^ := #$0d;

        'u': begin // inlined decoding of '\u0123' UTF-16 codepoint into UTF-8

          c4 := ConvertHexToBin[ord(P[1])];

          if c4<=15 then begin

            b := ConvertHexToBin[ord(P[2])];

            if b<=15 then begin

              c4 := c4 shl 4+b;

              b := ConvertHexToBin[ord(P[3])];

              if b<=15 then begin

                c4 := c4 shl 4+b;

                b := ConvertHexToBin[ord(P[4])];

                if b<=15 then begin

                  c4 := c4 shl 4+b;

                  case c4 of

                  0: begin

                    D^ := '?'; // \u0000 is an invalid value

                    inc(D);

                  end;

                  1..$7f: begin

                    D^ := AnsiChar(c4);

                    inc(D);

                  end;

                  $80..$7ff: begin

                    D[0] := AnsiChar($C0 or (c4 shr 6));

                    D[1] := AnsiChar($80 or (c4 and $3F));

                    inc(D,2);

                  end;

                  UTF16_HISURROGATE_MIN..UTF16_LOSURROGATE_MAX:

                    if PWord(P+5)^=ord('\')+ord('u') shl 8 then begin

                      inc(P,6);

                      surrogate := (ConvertHexToBin[ord(P[1])] shl 12)+

                                   (ConvertHexToBin[ord(P[2])] shl 8)+

                                   (ConvertHexToBin[ord(P[3])] shl 4)+

                                    ConvertHexToBin[ord(P[4])]; // optimistic approach

                      case c4 of // inlined UTF16CharToUtf8()

                      UTF16_HISURROGATE_MIN..UTF16_HISURROGATE_MAX:

                        c4 := ((c4-$D7C0)shl 10)+(surrogate xor UTF16_LOSURROGATE_MIN);

                      UTF16_LOSURROGATE_MIN..UTF16_LOSURROGATE_MAX:

                        c4 := ((surrogate-$D7C0)shl 10)+(c4 xor UTF16_LOSURROGATE_MIN);

                      end;

                      case c4 of

                      0..$7ff: b := 2;

                      $800..$ffff: b := 3;

                      $10000..$1FFFFF: b := 4;

                      $200000..$3FFFFFF: b := 5;

                      else b := 6;

                      end;

                      for j := b-1 downto 1 do begin

                        D[j] := AnsiChar((c4 and $3f)+$80);

                        c4 := c4 shr 6;

                      end;

                      D^ := AnsiChar(Byte(c4) or UTF8_FIRSTBYTE[b]);

                      inc(D,b);

                    end else begin

                      D^ := '?'; // unexpected surrogate without its pair

                      inc(D);

                    end;

                  else begin

                    D[0] := AnsiChar($E0 or (c4 shr 12));

                    D[1] := AnsiChar($80 or ((c4 shr 6) and $3F));

                    D[2] := AnsiChar($80 or (c4 and $3F));

                    inc(D,3);

                  end;

                  end;

                  inc(P,5);

                  continue;

                end;

              end;

            end;

          end;

          D^ := '?'; // bad formated hexa number -> '?0123'

        end;

        else D^ := P^; // litterals: '\"' -> '"'

      end;

      inc(P);

      inc(D);

    until false;

    // here P^='"'

    D^ := #0; // make zero-terminated

    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;

  '-','1'..'9': begin

num:// numerical field: all chars before end of field

    result := P;

    repeat

      if not (P^ in DigitFloatChars) then

        break;

      inc(P);

    until false;

    if P^=#0 then

      exit;

    if P^<=' ' then

      P^ := #0; // force numerical field with no trailing ' '

  end;

  else exit; // PDest=nil to indicate error

  end;

  if not (P^ in EndOfJSONField) then begin

    inc(P);

    while not (P^ in EndOfJSONField) do begin

      inc(P);

      if P^=#0 then

        exit; // leave PDest=nil for unexpected end

    end;

  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): PUTF8Char;

var Name: PUTF8Char;

    wasString: boolean;

    EndOfObject: AnsiChar;

begin  // should match GotoNextJSONObjectOrArray() and JsonPropNameValid()

  result := nil;

  if P=nil then

    exit;

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  Name := P; // put here to please some versions of Delphi compiler 

  case P^ of

  '_','A'..'Z','a'..'z','0'..'9','$': begin // e.g. '{age:{$gt:18}}'

    repeat

      inc(P);

    until not (ord(P[0]) in IsJsonIdentifier);

    if P^ in [#1..' '] then begin

      P^ := #0;

      inc(P);

    end;

    if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

    if not (P^ in [':','=']) then // allow both age:18 and age=18 pairs

      exit;

    P^ := #0;

    inc(P);

  end;

  '''': begin // single quotes won't handle nested quote character

    inc(P);

    Name := P;

    while P^<>'''' do

      if P^<' ' then

        exit else

        inc(P);

    P^ := #0;

    repeat inc(P) until not(P^ in [#1..' ']);

    if P^<>':' then

      exit;

    inc(P);

  end;

  '"': begin

    Name := GetJSONField(P,P,@wasString,@EndOfObject);

    if (Name=nil) or (not wasString) or (EndOfObject<>':') then

      exit;

  end else

    exit;

  end;

  result := Name;

end;



procedure GetJSONPropName(var P: PUTF8Char; out PropName: shortstring);

var Name: PAnsiChar;

begin // match GotoNextJSONObjectOrArray() and overloaded GetJSONPropName()

  PropName[0] := #0;

  if P=nil then

    exit;

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  Name := pointer(P);

  case P^ of

  '_','A'..'Z','a'..'z','0'..'9','$': begin // e.g. '{age:{$gt:18}}'

    repeat

      inc(P);

    until not (ord(P^) in IsJsonIdentifier);

    SetString(PropName,Name,P-Name);

    if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

    if not (P^ in [':','=']) then begin // allow both age:18 and age=18 pairs

      PropName[0] := #0;

      exit;

    end;

    inc(P);

  end;

  '''': begin // single quotes won't handle nested quote character

    inc(P);

    inc(Name);

    while P^<>'''' do

      if P^<' ' then

        exit else

        inc(P);

    SetString(PropName,Name,P-Name);

    repeat inc(P) until not(P^ in [#1..' ']);

    if P^<>':' then begin

      PropName[0] := #0;

      exit;

    end;

    inc(P);

  end;

  '"': begin

    inc(Name);

    P := GotoEndOfJSONString(P); // won't unescape JSON strings

    if P^<>'"' then

      exit;

    SetString(PropName,Name,P-Name);

    repeat inc(P) until not(P^ in [#1..' ']);

    if P^<>':' then begin

      PropName[0] := #0;

      exit;

    end;

    inc(P);

  end else

    exit;

  end;

end;



function GotoNextJSONPropName(P: PUTF8Char): PUTF8Char;

label s;

begin  // should match GotoNextJSONObjectOrArray()

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  result := nil;

  if P=nil then

    exit;

  case P^ of

  '_','A'..'Z','a'..'z','0'..'9','$': begin // e.g. '{age:{$gt:18}}'

    repeat

      inc(P);

    until not (ord(P^) in IsJsonIdentifier);

    if P^ in [#1..' '] then

      inc(P);

    if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

    if not (P^ in [':','=']) then // allow both age:18 and age=18 pairs

      exit;

  end;

  '''': begin // single quotes won't handle nested quote character

    inc(P);

    while P^<>'''' do

      if P^<' ' then

        exit else

        inc(P);

    goto s;

  end;

  '"': begin

    P := GotoEndOfJSONString(P);

    if P^<>'"' then

      exit;

s:  repeat inc(P) until not(P^ in [#1..' ']);

    if P^<>':' then

      exit;

  end else

    exit;

  end;

  repeat inc(P) until not(P^ in [#1..' ']);

  result := P;

end;



function GetJSONFieldOrObjectOrArray(var P: PUTF8Char; wasString: PBoolean=nil;

  EndOfObject: PUTF8Char=nil; HandleValuesAsObjectOrArray: Boolean=false): 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 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);

    if (result<>nil) and (not wStr) and (result^>='f') then

      if PInteger(result)^=TRUE_LOW then

        result := '1' else   // normalize true -> 1

      if PInteger(result)^=FALSE_LOW then

        result := '0';       // normalize false -> 0

    if wasString<>nil then

      wasString^ := wStr;

  end;

end;



function IsString(P: PUTF8Char): boolean;  // test if P^ is a "string" value

begin

  if P=nil then begin

    result := false;

    exit;

  end;

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  if (P[0] in ['0'..'9']) or // is first char numeric?

     ((P[0] in ['-','+']) and (P[1] in ['0'..'9'])) then begin

    // check if P^ is a true numerical value

    repeat inc(P) until not (P^ in ['0'..'9']); // check digits

    if P^='.' then

      repeat inc(P) until not (P^ in ['0'..'9']); // check fractional digits

    if (P^ in ['e','E']) and (P[1] in DigitChars) then begin

      inc(P);

      if P^='+' then inc(P) else

      if P^='-' then inc(P);

      while P^ in ['0'..'9'] do inc(P);

    end;

    if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

    result := (P^<>#0);

    exit;

  end else

    result := true; // don't begin with a numerical value -> must be a string

end;



function IsStringJSON(P: PUTF8Char): boolean;  // test if P^ is a "string" value

var c4: integer;

begin

  if P=nil then begin

    result := false;

    exit;

  end;

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  c4 := PInteger(P)^;

  if (((c4=NULL_LOW)or(c4=TRUE_LOW)) and (P[4] in EndOfJSONValueField)) or

     ((c4=FALSE_LOW) and (P[4]='e') and (P[5] in EndOfJSONValueField)) then begin

    result := false; // constants are no string

    exit;

  end else

  if (P[0] in ['1'..'9']) or // is first char numeric?

     ((P[0]='0') and not (P[1] in ['0'..'9'])) or // '012' excluded by JSON

     ((P[0]='-') and (P[1] in ['0'..'9'])) then begin

    // check if P^ is a true numerical value

    repeat inc(P) until not (P^ in ['0'..'9']); // check digits

    if P^='.' then

      repeat inc(P) until not (P^ in ['0'..'9']); // check fractional digits

    if (P^ in ['e','E']) and (P[1] in DigitChars) then begin

      inc(P);

      if P^='+' then inc(P) else

      if P^='-' then inc(P);

      while P^ in ['0'..'9'] do inc(P);

    end;

    if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

    result := (P^<>#0);

    exit;

  end else

    result := true; // don't begin with a numerical value -> must be a string

end;



function GotoEndJSONItem(P: PUTF8Char): PUTF8Char;

label next;

begin

  result := nil; // to notify unexpected end

  if P=nil then

    exit;

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  // get a field

  case P^ of

  #0: exit;

  '"': begin

    P := GotoEndOfJSONString(P);

    if P^<>'"' then

      exit; // P^ should be '"' here -> execute repeat.. below

  end;

  '[','{': begin

    P := GotoNextJSONObjectOrArray(P);

    if P=nil then

      exit;

    if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

    goto next;

  end;

  end;

  repeat // numeric or true/false/null or MongoDB extended {age:{$gt:18}}

    inc(P);

    if P^=#0 then exit; // unexpected end

  until P^ in [':',',',']','}'];

next:

  if P^=#0 then

    exit;

  result := P;

end;



procedure GetJSONItemAsRawJSON(var P: PUTF8Char; var result: RawJSON; EndOfObject: PAnsiChar);

var B: PUTF8Char;

begin

  result := '';

  if P=nil then

    exit;

  B := P;

  P := GotoEndJSONItem(B);

  if P=nil then

    exit;

  SetString(result,PAnsiChar(B),P-B);

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  if EndOfObject<>nil then

    EndOfObject^ := P^;

  if P^<>#0 then //if P^=',' then

    repeat inc(P) until not(P^ in [#1..' ']);

end;



function GotoNextJSONItem(P: PUTF8Char; NumberOfItemsToJump: cardinal;

  EndOfObject: PAnsiChar): PUTF8Char;

label next;

begin

 result := nil; // to notify unexpected end

 while NumberOfItemsToJump>0 do begin

   if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

   // get a field

   case P^ of

   #0: exit;

   '"': begin

     P := GotoEndOfJSONString(P);

     if P^<>'"' then

       exit; // P^ should be '"' here

   end;

   '[','{': begin

     P := GotoNextJSONObjectOrArray(P);

     if P=nil then

       exit;

     if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

     goto next;

   end;

   end;

   repeat // numeric or true/false/null or MongoDB extended {age:{$gt:18}}

     inc(P);

     if P^=#0 then exit; // unexpected end

   until P^ in [':',',',']','}'];

next:

   if P^=#0 then

     exit;

   if EndOfObject<>nil then

     EndOfObject^ := P^;

   inc(P);

   dec(NumberOfItemsToJump);

 end;

 result := P;

end;



function GotoNextJSONObjectOrArrayInternal(P,PMax: PUTF8Char; EndChar: AnsiChar): PUTF8Char;

label Prop;

begin // should match GetJSONPropName()

  result := nil;

  repeat

    case P^ of

    '{','[': begin

      if PMax=nil then

        P := GotoNextJSONObjectOrArray(P) else

        P := GotoNextJSONObjectOrArrayMax(P,PMax);

      if P=nil then exit;

    end;

    ':': if EndChar<>'}' then exit else inc(P); // syntax for JSON object only

    ',': inc(P); // comma appears in both JSON objects and arrays

    '}': if EndChar='}' then break else exit;

    ']': if EndChar=']' then break else exit;

    '"': begin

      P := GotoEndOfJSONString(P);

      if P^<>'"' then

        exit;

      inc(P);

    end;

    '-','+','0'..'9': // '0123' excluded by JSON, but not here

      repeat

        inc(P);

      until not (P^ in DigitFloatChars);

    't': if PInteger(P)^=TRUE_LOW then inc(P,4) else goto Prop;

    'f': if PInteger(P)^=FALSE_LOW then inc(P,5) else goto Prop;

    'n': if PInteger(P)^=NULL_LOW then inc(P,4) else goto Prop;

    '''': begin

      repeat inc(P); if P^<=' ' then exit; until P^='''';

      repeat inc(P) until not(P^ in [#1..' ']);

      if P^<>':' then exit;

    end;

    '/': begin

      repeat // allow extended /regex/ syntax

        inc(P);

        if P^=#0 then

          exit;

      until P^='/';

      repeat inc(P) until not(P^ in [#1..' ']);

    end;

    else begin

Prop: if not (ord(P^) in IsJsonIdentifierFirstChar) then

        exit; // expect e.g. '{age:{$gt:18}}'

      repeat

        inc(P);

      until not (ord(P^) in IsJsonIdentifier);

      while P^ in [#1..' '] do inc(P);

      if P^='(' then begin // handle e.g. "born":isodate("1969-12-31")

        inc(P);

        while P^ in [#1..' '] do inc(P);

        if P^='"' then begin

         P := GotoEndOfJSONString(P);

         if P^<>'"' then

          exit;

        end;

        inc(P);

        while P^ in [#1..' '] do inc(P);

        if P^<>')' then

          exit;

        inc(P);

       end

       else

       if P^<>':' then exit;

    end;

    end;

    if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

    if (PMax<>nil) and (P>=PMax) then

      exit;

  until P^=EndChar;

  result := P+1;

end;



function GotoNextJSONObjectOrArray(P: PUTF8Char; EndChar: AnsiChar=#0): PUTF8Char;

label Prop;

begin // should match GetJSONPropName()

  result := nil; // mark error or unexpected end (#0)

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  if EndChar=#0 then begin

    case P^ of

    '[': EndChar := ']';

    '{': EndChar := '}';

    else exit;

    end;

    repeat inc(P) until not(P^ in [#1..' ']);

  end;

  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)

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  case P^ of

  '[': EndChar := ']';

  '{': EndChar := '}';

  else exit;

  end;

  repeat inc(P) until not(P^ in [#1..' ']);

  result := GotoNextJSONObjectOrArrayInternal(P,PMax,EndChar);

end;



procedure RemoveCommentsFromJSON(P: PUTF8Char);

begin // replace comments by ' ' characters which will be ignored by parser

  if P<>nil then

  while P^<>#0 do begin

    case P^ of

      '"': begin

        P := GotoEndOfJSONString(P);

        if P^<>'"' then

          exit;

      end;

      '/': begin

         inc(P);

         case P^ of

           '/': begin // this is // comment - replace by ' '

             dec(P);

             repeat

               P^ := ' ';

               inc(P)

             until P^ in [#0, #10, #13];

           end;

           '*': begin // this is /* comment - replace by ' ' but keep CRLF

             P[-1] := ' ';

             repeat

               if not(P^ in [#10, #13]) then

                 P^ := ' '; // keep CRLF for correct line numbering (e.g. for error)

               inc(P);

               if PWord(P)^=ord('*')+ord('/')shl 8 then begin

                 PWord(P)^ := $2020;

                 inc(P,2);

                 break;

               end;

             until P^=#0;

           end;

         end;

      end;

    end;

    inc(P);

  end;

end;



procedure JSONBufferToXML(P: PUTF8Char; const Header,NameSpace: RawUTF8;

  out result: RawUTF8);

var i,j,L: integer;

begin

  if P=nil then

    result := Header else

    with TTextWriter.CreateOwnedStream 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,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);

begin

  if P<>nil then

    with TTextWriter.CreateOwnedStream(65536) do

    try

      AddJSONReformat(P,Format,nil);

      SetText(result);

    finally

      Free;

    end;

end;



function JSONReformat(const JSON: RawUTF8; Format: TTextWriterJSONFormat): RawUTF8;

var n: integer;

    tmp: TSynTempBuffer;

begin

  tmp.Init(JSON);

  if tmp.len<4096 then

    n := 4096 else // minimal rough estimation of the output buffer size

    n := tmp.Len shr 2;

  with TTextWriter.CreateOwnedStream(n) do

  try

    AddJSONReformat(tmp.buf,Format,nil);

    SetText(result);

  finally

    Free;

    tmp.Done;

  end;

end;



function JSONBufferReformatToFile(P: PUTF8Char; const Dest: TFileName;

  Format: TTextWriterJSONFormat=jsonHumanReadable): boolean;

var F: TFileStream;

begin

  try

    F := TFileStream.Create(Dest,fmCreate);

    try

      with TTextWriter.Create(F,256*1024) 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;





{ TSynPersistentWithPassword }



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.ComputePlainPassword(const CypheredPassword: RawUTF8;

  CustomKey: cardinal): RawUTF8;

var instance: TSynPersistentWithPassword;

begin

  instance := TSynPersistentWithPassword.Create;

  try

    instance.Key := CustomKey;

    instance.fPassWord := CypheredPassword;

    result := instance.GetPassWordPlain;

  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

  if (self=nil) or (fPassWord='') then

    result := '' else begin

    result := Base64ToBin(fPassWord);

    SymmetricEncrypt(GetKey,RawByteString(result));

  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(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: TPUtf8CharDynArray;

begin

  fKey := Key;

  privateCopy := JSON;

  JSONDecode(privateCopy,['Kind','ServerName','DatabaseName','User','Password'],values);

  UTF8DecodeToString(values[0],StrLen(values[0]),fKind);

  fServerName := values[1];

  fDatabaseName := values[2];

  fUser := values[3];

  fPassWord := values[4];

end;



function TSynConnectionDefinition.SaveToJSON: RawUTF8;

begin

  result := JSONEncode(['Kind',fKind,'ServerName',fServerName,

    'DatabaseName',fDatabaseName,'User',fUser,'Password',fPassword]);

end;





{ ************ filtering and validation classes and functions }



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: set of AnsiChar = [#33..#255] -

     ['(', ')', '<', '>', '@', ',', ';', ':', '\', '/', '"', '.', '[', ']', #127];

  // Valid characters in a "quoted-string"

  quoted_string_chars: set of AnsiChar = [#0..#255] - ['"', #13, '\'];

  // Valid characters in a subdomain

  letters: set of AnsiChar = ['A'..'Z', 'a'..'z'];

  letters_digits: set of AnsiChar = ['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 := GetHighUTF8UCS4Inlined(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;





function IsMatch(const Pattern, Text: RawUTF8; CaseInsensitive: boolean): boolean;

// code below adapted from ZMatchPattern.pas - http://www.zeoslib.sourceforge.net



  type

    TMatch = (mNONE, mABORT, mEND, mLITERAL, mPATTERN, mRANGE, mVALID);

  const

    SINGLE	= '?';

    KLEENE_STAR = '*';

    RANGE_OPEN	= '[';

    RANGE = '-';

    RANGE_CLOSE = ']';

    CARET_NEGATE = '^';

    EXCLAMATION_NEGATE	= '!';



  function MatchAfterStar(Pattern, Text: RawUTF8): TMatch; forward;



  function Matche(const Pattern, Text: RawUTF8): TMatch;

  var RangeStart, RangeEnd, P, T, PLen, TLen: Integer;

      Invert, MemberMatch: Boolean;

  begin

    P := 1;

    T := 1;

    PLen := Length(pattern);

    TLen := Length(text);

    result := mNONE;

    while ((result = mNONE) and (P <= PLen)) do begin

      if T > TLen then begin

        if (Pattern[P] = KLEENE_STAR) and (P+1 > PLen) then

          result := mVALID else

          result := mABORT;

        exit;

      end else

      case Pattern[P] of

        KLEENE_STAR:

          result := MatchAfterStar(Copy(Pattern,P,PLen),Copy(Text,T,TLen));

        RANGE_OPEN: begin

          inc(P);

          Invert := False;

          if (Pattern[P] = EXCLAMATION_NEGATE) or

            (Pattern[P] = CARET_NEGATE) then begin

            Invert := True;

            inc(P);

          end;

          if (Pattern[P] = RANGE_CLOSE) then begin

            result := mPATTERN;

            exit;

          end;

          MemberMatch := False;

          while Pattern[P] <> RANGE_CLOSE do begin

            RangeStart := P;

            RangeEnd := P;

            inc(P);

            if P > PLen then begin

              result := mPATTERN;

              exit;

            end;

            if Pattern[P] = RANGE then begin

              inc(P);

              RangeEnd := P;

              if (P > PLen) or (Pattern[RangeEnd] = RANGE_CLOSE) then begin

                result := mPATTERN;

                exit;

              end;

              inc(P);

            end;

            if P > PLen then begin

              result := mPATTERN;

              exit;

            end;

            if RangeStart < RangeEnd then begin

              if (Text[T] >= Pattern[RangeStart]) and

                 (Text[T] <= Pattern[RangeEnd]) then begin

                MemberMatch := True;

                break;

              end;

            end

            else begin

              if (Text[T] >= Pattern[RangeEnd]) and

                 (Text[T] <= Pattern[RangeStart]) then begin

                MemberMatch := True;

                break;

              end;

            end;

          end;

          if (Invert and MemberMatch) or (not (Invert or MemberMatch)) then begin

            result := mRANGE;

            exit;

          end;

          if MemberMatch then

            while (P <= PLen) and (Pattern[P] <> RANGE_CLOSE) do

              inc(P);

          if P > PLen then begin

            result := mPATTERN;

            exit;

          end;

        end;

      else

        if Pattern[P] <> SINGLE then

          if Pattern[P] <> Text[T] then

            result := mLITERAL;

      end;

      inc(P);

      inc(T);

    end;

    if result = mNONE then

      if T <= TLen then

        result := mEND else

        result := mVALID;

  end;



  function MatchAfterStar(Pattern, Text: RawUTF8): TMatch;

  var P, T, PLen, TLen: Integer;

  begin

    result := mNONE;

    P := 1;

    T := 1;

    PLen := Length(Pattern);

    TLen := Length(Text);

    if TLen = 1 then begin

      result := mVALID;

      exit;

    end else

    if (PLen = 0) or (TLen = 0) then begin

      result := mABORT;

      exit;

    end;

    while ((T <= TLen) and (P < PLen)) and ((Pattern[P] = SINGLE) or

      (Pattern[P] = KLEENE_STAR)) do begin

      if Pattern[P] = SINGLE then

        inc(T);

      inc(P);

    end;

    if T >= TLen then begin

      result := mABORT;

      exit;

    end else

    if P >= PLen then begin

      result := mVALID;

      exit;

    end;

    repeat

      if (Pattern[P] = Text[T]) or (Pattern[P] = RANGE_OPEN) then begin

        Pattern := Copy(Pattern, P, PLen);

        Text := Copy(Text, T, TLen);

        PLen := Length(Pattern);

        TLen := Length(Text);

        p := 1;

        t := 1;

        result  := Matche(Pattern, Text);

        if result <> mVALID then

          result := mNONE; // retry until end of Text, (check below) or result valid

      end;

      inc(T);

      if (T > TLen) or (P > PLen) then begin

        result := mABORT;

        exit;

      end;

    until result <> mNONE;

  end;



begin // IsMatch() main block

  if CaseInsensitive then

    result := (Matche(LowerCase(Pattern), LowerCase(Text)) = mVALID) else

    result := (Matche(Pattern, Text) = mVALID);

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: TPUtf8CharDynArray;

    tmp: TSynTempBuffer;

begin

  tmp.Init(Value);

  JSONDecode(tmp.buf,['MaxLength','UTF8Length'],V);

  fMaxLength := GetCardinalDef(V[0],0);

  fUTF8Length := IdemPChar(V[1],'1') or IdemPChar(V[1],'TRUE');

  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..19] 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','tel','travel'); // no xxx !

begin

  if IsValidEmail(pointer(Value)) then

  repeat

    DOM := lowercase(copy(Value,PosEx('@',Value)+1,100));

    if length(DOM)>63 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: TPUtf8CharDynArray;

    tmp: TSynTempBuffer;

begin

  inherited;

  tmp.Init(Value);

  JSONDecode(tmp.buf,['AllowedTLD','ForbiddenTLD','ForbiddenDomains','AnyTLD'],V);

  LowerCaseCopy(V[0],StrLen(V[0]),fAllowedTLD);

  LowerCaseCopy(V[1],StrLen(V[1]),fForbiddenTLD);

  LowerCaseCopy(V[2],StrLen(V[2]),fForbiddenDomains);

  AnyTLD := IdemPChar(V[3],'1') or IdemPChar(V[3],'TRUE');

  tmp.Done;

end;





{ TSynValidatePattern }



function TSynValidatePattern.Process(aFieldIndex: integer; const Value: RawUTF8;

  var ErrorMsg: string): boolean;

begin

  result := IsMatch(fParameters,Value,ClassType=TSynValidatePatternI);

  if not result then

    ErrorMsg := Format(sInvalidPattern,[UTF8ToString(Value)]);

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: TPUtf8CharDynArray;

    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);

    if length(V)<>length(fProps)+1 then

      exit;

    for i := 0 to high(fProps) do

      fProps[i] := GetCardinalDef(V[i],fProps[i]);

    fUTF8Length := IdemPChar(V[length(fProps)],'1') or

                   IdemPChar(V[length(fProps)],'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;





{ ************ some console functions }



var

  TextAttr: integer = ord(ccDarkGray);



{$ifdef MSWINDOWS}



procedure InitConsole;

begin

  if StdOut=0 then begin

   StdOut := GetStdHandle(STD_OUTPUT_HANDLE);

   if StdOut=INVALID_HANDLE_VALUE then

     StdOut := 0;

  end;

end;



procedure TextColor(Color: TConsoleColor);

var oldAttr: integer;

begin

  InitConsole;

  oldAttr := TextAttr;

  TextAttr := (TextAttr and $F0) or ord(Color);

  if TextAttr<>oldAttr then

    SetConsoleTextAttribute(StdOut,TextAttr);

end;



procedure TextBackground(Color: TConsoleColor);

var oldAttr: integer;

begin

  InitConsole;

  oldAttr := TextAttr;

  TextAttr := (TextAttr and $0F) or (ord(Color) shl 4);

  if TextAttr<>oldAttr then

    SetConsoleTextAttribute(StdOut,TextAttr);

end;



function ConsoleKeyPressed(ExpectedKey: Word): Boolean;

var lpNumberOfEvents: DWORD;

    lpBuffer: TInputRecord;

    lpNumberOfEventsRead : DWORD;

    nStdHandle: THandle;

begin

  result := false;

  nStdHandle := GetStdHandle(STD_INPUT_HANDLE);

  lpNumberOfEvents := 0;

  GetNumberOfConsoleInputEvents(nStdHandle,lpNumberOfEvents);

  if lpNumberOfEvents<>0 then begin

    PeekConsoleInput(nStdHandle,lpBuffer,1,lpNumberOfEventsRead);

    if lpNumberOfEventsRead<>0 then

      if lpBuffer.EventType=KEY_EVENT then

        if lpBuffer.Event.KeyEvent.bKeyDown and

           ((ExpectedKey=0) or (lpBuffer.Event.KeyEvent.wVirtualKeyCode=ExpectedKey)) then

          result := true else

          FlushConsoleInputBuffer(nStdHandle) else

        FlushConsoleInputBuffer(nStdHandle);

  end;

end;



procedure ConsoleWaitForEnterKey;

{$ifdef DELPHI5OROLDER}

begin

  readln;

end;

{$else}

var msg: TMsg;

begin

  while not ConsoleKeyPressed(VK_RETURN) do begin

    {$ifndef LVCL}

    if GetCurrentThreadID=MainThreadID then

      CheckSynchronize{$ifdef WITHUXTHEME}(1000){$endif}  else

    {$endif}

      WaitMessage;

    while PeekMessage(msg,0,0,0,PM_REMOVE) do

      if Msg.Message=WM_QUIT then

        exit else begin

        TranslateMessage(Msg);

        DispatchMessage(Msg);

      end;

  end;

end;

{$endif DELPHI5OROLDER}



{$else MSWINDOWS}



// we by-pass crt.pp since this unit cancels the SIGINT signal



{$I-}

procedure TextColor(Color: TConsoleColor);

const AnsiTbl : string[8]='04261537';

begin

  if ord(color)=TextAttr then

    exit;

  TextAttr := ord(color);

  if ord(color)>=8 then

    write(#27'[1;3') else

    write(#27'[0;3');

  write(AnsiTbl[(ord(color) and 7)+1],'m');

  ioresult;

end;

{$I+}



procedure TextBackground(Color: TConsoleColor);

begin // not implemented yet - but not needed either

end;



procedure ConsoleWaitForEnterKey;

begin

  Readln;

end;



{$endif MSWINDOWS}



function Utf8ToConsole(const S: RawUTF8): RawByteString;

begin

  {$ifdef MSWINDOWS}

  result := TSynAnsiConvert.Engine(CP_OEMCP).UTF8ToAnsi(S);

  {$else}

  result := S;

  {$endif}

end;



{$I-}

procedure ConsoleShowFatalException(E: Exception);

begin

  ioresult;

  TextColor(ccLightRed);

  write(#13#10'Fatal exception ');

  TextColor(ccWhite);

  write(E.ClassName);

  TextColor(ccLightRed);

  Writeln(' raised with message:'#13#10' ',UTF8ToConsole(StringToUTF8(E.Message)));

  TextColor(ccLightGray);

  writeln(#13#10'Program will now abort');

  {$ifndef LINUX}

  writeln('Press [Enter] to quit');

  if ioresult=0 then

    Readln;

  {$endif}

  ioresult;

end;

{$I+}







{ ************ Unit-Testing classes and functions }



function KB(bytes: Int64): RawUTF8;

var hi,rem: cardinal;

begin

  if bytes>=1 shl 20 then begin

    if bytes>=Int64(1) shl 40 then begin

      bytes := bytes shr 20;

      result := ' TB';

    end else

    if bytes>=1 shl 30 then begin

      bytes := bytes shr 10;

      result := ' GB';

    end else

      result := ' MB';

    rem := (PtrUInt(bytes) and pred(1 shl 20))div (102*1024);

    hi := bytes shr 20;

    if rem=10 then begin

      rem := 0;

      inc(hi);

    end;

    if rem<>0 then

      result := FormatUTF8('%.%%',[hi,rem,result]) else

      result := FormatUTF8('%%',[hi,result]);

  end else

  if bytes>1023*9 then

    result := UInt32ToUtf8(PtrUInt(bytes) shr 10)+' KB' else

    result := UInt32ToUtf8(PtrUInt(bytes))+' B';

end;



function IntToThousandString(Value: integer; const ThousandSep: RawUTF8=','): RawUTF8;

var i,L,Len: cardinal;

begin

  Int32ToUtf8(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): RawUTF8;

function TwoDigitToString(value: cardinal): RawUTF8;

var L: integer;

begin

  UInt32ToUtf8(value,result);

  L := length(result);

  if L=1 then

    result := '0.0'+result else // '3' -> '0.03'

  if L=2 then

    result := '0.'+result else // '35' -> '0.35'

    insert('.',result,L-1); // '103' -> '1.03'

end;

begin

  if Micro<=0 then

    result := '0us' else

  if Micro<1000 then

    result := UInt32ToUtf8(Int64Rec(Micro).Lo)+'us' else

  if Micro<1000*1000 then

    result := TwoDigitToString(Micro div 10)+'ms' else

    result := TwoDigitToString(Micro div (10*1000))+'s';

end;



function IsInitializedCriticalSection(const CS: TRTLCriticalSection): Boolean;

begin

  result := not IsZero(@CS,sizeof(CS));

end;



procedure InitializeCriticalSectionIfNeededAndEnter(var CS: TRTLCriticalSection);

begin

  if IsZero(@CS,sizeof(CS)) then

    InitializeCriticalSection(CS);

  EnterCriticalSection(CS);

end;



procedure DeleteCriticalSectionIfNeeded(var CS: TRTLCriticalSection);

begin

  if not IsZero(@CS,sizeof(CS)) then

    DeleteCriticalSection(CS);

end;





{ ******************* process monitoring / statistics ********************** }



{ TPrecisionTimer }



function TPrecisionTimer.ByCount(Count: QWord): RawUTF8;

begin

  if Count=0 then

    result := '0' else // avoid div per 0 exception

    result := MicroSecToString(iTime div Count);

end;



function TPrecisionTimer.PerSec(const Count: QWord): QWord;

begin

  if iTime<=0 then // avoid negative value in case of incorrect Start/Stop sequence

    result := 0 else // avoid div per 0 exception

    result := (Count*QWord(1000*1000)) div iTime;

end;



procedure TPrecisionTimer.Init;

begin

  FillcharFast(self,sizeof(self),0);

end;



procedure TPrecisionTimer.Start;

begin

  FillcharFast(self,sizeof(self),0);

  QueryPerformanceCounter(iStart);

  iLast := iStart;

end;



procedure TPrecisionTimer.ComputeTime;

begin

  QueryPerformanceCounter(iStop);

  if iFreq=0 then begin

    QueryPerformanceFrequency(iFreq);

    if iFreq=0 then begin

      iTime := 0;

      iLastTime := 0;

      exit;

    end;

  end;

  iTime := ((iStop-iStart)*QWord(1000*1000))div iFreq;

  iLastTime := ((iStop-iLast)*QWord(1000*1000))div iFreq;

end;



procedure TPrecisionTimer.FromExternalMicroSeconds(const MicroSeconds: QWord);

begin

  iLastTime := MicroSeconds;

  inc(iTime,MicroSeconds);

end;



function TPrecisionTimer.FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord;

begin // very close to ComputeTime

  if iFreq=0 then begin

    iTime := 0;

    QueryPerformanceFrequency(iFreq);

  end;

  if iFreq=0 then

    iLastTime := 0 else

    FromExternalMicroSeconds((CounterDiff*QWord(1000*1000))div iFreq);

  result := iLastTime;

end;



function TPrecisionTimer.Stop: RawUTF8;

begin

  ComputeTime;

  result := Time;

end;



procedure TPrecisionTimer.Pause;

begin

  QueryPerformanceCounter(iResume);

  dec(iResume,iStart);

  inc(fPauseCount);

end;



procedure TPrecisionTimer.Resume;

begin

  QueryPerformanceCounter(iStart);

  iLast := iStart;

  dec(iStart,iResume);

  iResume := 0;

end;



function TPrecisionTimer.Time: RawUTF8;

begin

  result := MicroSecToString(iTime);

end;



function TPrecisionTimer.LastTime: RawUTF8;

begin

  result := MicroSecToString(iLastTime);

end;





type

  /// a class used internaly by TPrecisionTimer.ProfileMethod

  TPrecisionTimerProfiler = class(TInterfacedObject)

  protected

    fTimer: PPrecisionTimer;

  public

    constructor Create(aTimer: PPrecisionTimer);

    destructor Destroy; override;

  end;



constructor TPrecisionTimerProfiler.Create(aTimer: PPrecisionTimer);

begin

  fTimer := aTimer;

end;



destructor TPrecisionTimerProfiler.Destroy;

begin

  if fTimer<>nil then

    fTimer^.Pause;

  inherited;

end;





function TPrecisionTimer.ProfileCurrentMethod: IUnknown;

begin

  if iStart=0 then

    Start else

    Resume;

  result := TPrecisionTimerProfiler.Create(@self);

end;





{ TLocalPrecisionTimer }



function TLocalPrecisionTimer.ByCount(Count: cardinal): RawUTF8;

begin

  result := fTimer.ByCount(Count);

end;



procedure TLocalPrecisionTimer.Pause;

begin

  fTimer.Pause;

end;



function TLocalPrecisionTimer.PerSec(Count: cardinal): cardinal;

begin

  result := fTimer.PerSec(Count);

end;



procedure TLocalPrecisionTimer.Resume;

begin

  fTimer.Resume;

end;



procedure TLocalPrecisionTimer.Start;

begin

  fTimer.Start;

end;



function TLocalPrecisionTimer.Stop: RawUTF8;

begin

  result := fTimer.Stop;

end;



constructor TLocalPrecisionTimer.CreateAndStart;

begin

  inherited;

  fTimer.Start;

end;



{ TSynMonitorTime }



function TSynMonitorTime.GetAsText: RawUTF8;

begin

  result := MicroSecToString(fMicroSeconds);

end;



function TSynMonitorTime.PerSecond(const Count: QWord): QWord;

begin

  if PInt64(@fMicroSeconds)^<=0 then // avoid negative or div per 0

    result := 0 else

    result := (Count*QWord(1000*1000)) div fMicroSeconds;

end;





{ TSynMonitorOneTime }



function TSynMonitorOneTime.GetAsText: RawUTF8;

begin

  result := MicroSecToString(fMicroSeconds);

end;



function TSynMonitorOneTime.PerSecond(const Count: QWord): QWord;

begin

  if PInt64(@fMicroSeconds)^<=0 then // avoid negative or div per 0

    result := 0 else

    result := (Count*QWord(1000*1000)) div fMicroSeconds;

end;





{ TSynMonitorSize }



function TSynMonitorSize.GetAsText: RawUTF8;

begin

  result := KB(fBytes);

end;



{ TSynMonitorOneSize }



function TSynMonitorOneSize.GetAsText: RawUTF8;

begin

  result := KB(fBytes);

end;



{ TSynMonitorThroughput }



function TSynMonitorThroughput.GetAsText: RawUTF8;

begin

  result := KB(fBytesPerSec)+'/s';

end;





{ TSynMonitor }



constructor TSynMonitor.Create;

begin

  inherited Create;

  fTotalTime := TSynMonitorTime.Create;

  fLastTime := TSynMonitorOneTime.Create;

  fMinimalTime := TSynMonitorOneTime.Create;

  fAverageTime := TSynMonitorOneTime.Create;

  fMaximalTime := TSynMonitorOneTime.Create;

  InitializeCriticalSection(fLock);

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;

  DeleteCriticalSection(fLock);

  inherited Destroy;

end;



procedure TSynMonitor.Lock;

begin

  EnterCriticalSection(fLock);

end;



procedure TSynMonitor.UnLock;

begin

  LeaveCriticalSection(fLock);

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]);

  EnterCriticalSection(fLock);

  try

    InternalTimer.Resume;

    fTaskStatus := taskNotStarted;

    fProcessing := true;

  finally

    LeaveCriticalSection(fLock);

  end;

end;



procedure TSynMonitor.ProcessDoTask;

begin

  EnterCriticalSection(fLock);

  try

    inc(fTaskCount);

    fTaskStatus := taskStarted;

    Changed;

  finally

    LeaveCriticalSection(fLock);

  end;

end;



procedure TSynMonitor.ProcessStartTask;

begin

  if fProcessing then

    raise ESynException.CreateUTF8('Reentrant %.ProcessStart',[self]);

  EnterCriticalSection(fLock);

  try

    InternalTimer.Resume;

    fProcessing := true;

    inc(fTaskCount);

    fTaskStatus := taskStarted;

    Changed;

  finally

    LeaveCriticalSection(fLock);

  end;

end;



procedure TSynMonitor.ProcessEnd;

begin

  EnterCriticalSection(fLock);

  try

    InternalTimer.Pause;

    InternalTimer.ComputeTime;

    LockedFromProcessTimer;

  finally

    LeaveCriticalSection(fLock);

  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.LastTimeInMicroSec<fMinimalTime.MicroSec) then

      fMinimalTime.MicroSec := InternalTimer.LastTimeInMicroSec;

    if InternalTimer.LastTimeInMicroSec>fMaximalTime.MicroSec then

      fMaximalTime.MicroSec := InternalTimer.LastTimeInMicroSec;

    fTaskStatus := taskNotStarted;

  end;

  LockedPerSecProperties;

  fProcessing := false;

  Changed;

end;



function TSynMonitor.FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord;

begin

  EnterCriticalSection(fLock);

  try // thread-safe ProcessStart+ProcessDoTask+ProcessEnd

    inc(fTaskCount);

    fTaskStatus := taskStarted;

    result := InternalTimer.FromExternalQueryPerformanceCounters(CounterDiff);

    LockedFromProcessTimer;

  finally

    LeaveCriticalSection(fLock);

  end;

end;



procedure TSynMonitor.FromExternalMicroSeconds(const MicroSecondsElapsed: QWord);

begin

  EnterCriticalSection(fLock);

  try // thread-safe ProcessStart+ProcessDoTask+ProcessEnd

    inc(fTaskCount);

    fTaskStatus := taskStarted;

    InternalTimer.FromExternalMicroSeconds(MicroSecondsElapsed);

    LockedFromProcessTimer;

  finally

    LeaveCriticalSection(fLock);

  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

  EnterCriticalSection(fLock);

  try

    if not VarIsEmptyOrNull(info) then

      inc(fInternalErrors);

    fLastInternalError := info;

    Changed;

  finally

    LeaveCriticalSection(fLock);

  end;

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 := Round(fTotalTime.MicroSec/fTaskCount);

end;



procedure TSynMonitor.Sum(another: TSynMonitor);

begin

  if (self=nil) or (another=nil) then

    exit;

  EnterCriticalSection(fLock);

  EnterCriticalSection(another.fLock);

  try

    LockedSum(another);

  finally

    LeaveCriticalSection(another.fLock);

    LeaveCriticalSection(fLock);

  end;

end;



procedure TSynMonitor.LockedSum(another: TSynMonitor);

begin

  fTotalTime.MicroSec := fTotalTime.MicroSec+another.fTotalTime.MicroSec;

  if (fMinimalTime.MicroSec=0) or

     (another.fMinimalTime.MicroSec<fMinimalTime.MicroSec) then

    fMinimalTime.MicroSec := another.fMinimalTime.MicroSec;

  if another.fMaximalTime.MicroSec>fMaximalTime.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

  EnterCriticalSection(fLock);

  try

    W.WriteObject(self);

  finally

    LeaveCriticalSection(fLock);

  end;

end;



procedure TSynMonitor.ComputeDetailsTo(W: TTextWriter);

begin

  EnterCriticalSection(fLock);

  try

    LockedPerSecProperties; // may not have been calculated after Sum()

    WriteDetailsTo(W);

  finally

    LeaveCriticalSection(fLock);

  end;

end;



function TSynMonitor.ComputeDetailsJSON: RawUTF8;

var W: TTextWriter;

begin

  W := DefaultTextWriterJSONClass.CreateOwnedStream;

  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;

  fThroughput := TSynMonitorThroughput.Create;

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

  EnterCriticalSection(fLock);

  try

    fSize.Bytes := fSize.Bytes+Bytes;

  finally

    LeaveCriticalSection(fLock);

  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;

  fOutput := TSynMonitorSize.Create;

  fInputThroughput := TSynMonitorThroughput.Create;

  fOutputThroughput := TSynMonitorThroughput.Create;

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

  EnterCriticalSection(fLock);

  try

    fInput.Bytes := fInput.Bytes+Incoming;

    fOutput.Bytes := fOutput.Bytes+Outgoing;

  finally

    LeaveCriticalSection(fLock);

  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

  EnterCriticalSection(fLock);

  try

    inc(fClientsCurrent);

    if fClientsCurrent>fClientsMax then

      fClientsMax := fClientsCurrent;

    Changed;

  finally

    LeaveCriticalSection(fLock);

  end;

end;



procedure TSynMonitorServer.ClientDisconnect;

begin

  EnterCriticalSection(fLock);

  try

    if fClientsCurrent>0 then

      dec(fClientsCurrent);

    Changed;

  finally

    LeaveCriticalSection(fLock);

  end;

end;



procedure TSynMonitorServer.ClientDisconnectAll;

begin

  EnterCriticalSection(fLock);

  try

    fClientsCurrent := 0;

    Changed;

  finally

    LeaveCriticalSection(fLock);

  end;

end;



function TSynMonitorServer.GetClientsCurrent: TSynMonitorOneCount;

begin

  EnterCriticalSection(fLock);

  try

    result := fClientsCurrent;

  finally

    LeaveCriticalSection(fLock);

  end;

end;



function TSynMonitorServer.AddCurrentRequestCount(diff: integer): integer;

begin

  EnterCriticalSection(fLock);

  try

    inc(fCurrentRequestCount,diff);

    result := fCurrentRequestCount;

  finally

    LeaveCriticalSection(fLock);

  end;

end;



{ TSynMonitorMemory }



constructor TSynMonitorMemory.Create;

begin

  FAllocatedUsed := TSynMonitorOneSize.create;

  FAllocatedReserved := TSynMonitorOneSize.create;

  FPhysicalMemoryFree := TSynMonitorOneSize.Create;

  FVirtualMemoryFree := TSynMonitorOneSize.Create;

  FPagingFileTotal := TSynMonitorOneSize.Create;

  FPhysicalMemoryTotal := TSynMonitorOneSize.Create;

  FVirtualMemoryTotal := TSynMonitorOneSize.Create;

  FPagingFileFree := TSynMonitorOneSize.Create;

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: RawUTF8;

begin

  with TSynMonitorMemory.Create do

  try

    FormatUTF8('% / %',[PhysicalMemoryFree.Text,PhysicalMemoryTotal.Text],result);

  finally

    Free;

  end;

end;



{$ifndef NOVARIANTS}

class function TSynMonitorMemory.ToVariant: variant;

begin

  with TSynMonitorMemory.Create do

  try

    result := _JsonFastFmt('{Allocated:{reserved:%,used:%},Physical:{total:%,free:%},'+

      'Virtual:{total:%,free:%},Paged:{total:%,free:%}}',

      [AllocatedReserved.Bytes shr 10,AllocatedUsed.Bytes shr 10,

       PhysicalMemoryTotal.Bytes shr 10,PhysicalMemoryFree.Bytes shr 10,

       {$ifdef MSWINDOWS}

       VirtualMemoryTotal.Bytes shr 10,VirtualMemoryFree.Bytes shr 10,

       {$endif}

       PagingFileTotal.Bytes shr 10,PagingFileFree.Bytes shr 10],[]);

  finally

    Free;

  end;

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}



procedure TSynMonitorMemory.RetrieveMemoryInfo;

procedure RetrieveInfo;

{$ifndef FPC}

var Heap: TMemoryManagerState;

    sb: integer;

    tot,res: QWord;

{$endif}

{$ifdef MSWINDOWS}

var MemoryStatus: TMemoryStatusEx;

begin

  FillcharFast(MemoryStatus,SizeOf(MemoryStatus),0);

  MemoryStatus.dwLength := SizeOf(MemoryStatus);

  GlobalMemoryStatusEx(MemoryStatus);

  FMemoryLoadPercent := MemoryStatus.dwMemoryLoad;

  FPhysicalMemoryTotal.fBytes := MemoryStatus.ullTotalPhys;

  FPhysicalMemoryFree.fBytes := MemoryStatus.ullAvailPhys;

  FPagingFileTotal.fBytes := MemoryStatus.ullTotalPageFile;

  FPagingFileFree.fBytes := MemoryStatus.ullAvailPageFile;

  FVirtualMemoryTotal.fBytes := MemoryStatus.ullTotalVirtual;

  FVirtualMemoryFree.fBytes := MemoryStatus.ullAvailVirtual;

{$else}

{$ifdef LINUX}

var si: TSysInfo;

begin

  {$ifdef FPC}

  SysInfo(@si);

  {$else}

  SysInfo(si);

  {$endif}

  if si.totalram<>0 then // avoid div per 0 exception

    FMemoryLoadPercent := ((si.totalram-si.freeram)*100)div si.totalram;

  FPhysicalMemoryTotal.fBytes := si.totalram;

  FPhysicalMemoryFree.fBytes := si.freeram;

  FPagingFileTotal.fBytes := si.totalswap;

  FPagingFileFree.fBytes := si.freeswap;

  // virtual memory information is not available under Linux

{$else}

begin // e.g. Darwin

{$endif LINUX}

{$endif MSWINDOWS}

{$ifdef FPC}

  with GetHeapStatus do begin

    FAllocatedUsed.fBytes := TotalAllocated;

    FAllocatedReserved.fBytes := TotalAllocated+TotalFree;

  end;

{$else}

{$ifdef LVCL}

  tot := 0;

  res := 0;

{$else}

  GetMemoryManagerState(Heap); // direct access to FastMM4 statistics

  tot := Heap.TotalAllocatedMediumBlockSize+Heap.TotalAllocatedLargeBlockSize;

  res := Heap.ReservedMediumBlockAddressSpace+Heap.ReservedLargeBlockAddressSpace;

  for sb := 0 to high(Heap.SmallBlockTypeStates) do

    with Heap.SmallBlockTypeStates[sb] do begin

      inc(tot,UseableBlockSize*AllocatedBlockCount);

      inc(res,ReservedAddressSpace);

    end;

{$endif LVCL}

  FAllocatedUsed.fBytes := tot;

  FAllocatedReserved.fBytes := res;

{$endif FPC}

end;

var tix: cardinal;

begin

  tix := GetTickCount64 shr 7; // allow 128 ms resolution for updates

  if fLastMemoryInfoRetrievedTix<>tix then begin

    fLastMemoryInfoRetrievedTix := tix;

    RetrieveInfo;

  end;

end;





{ TSynMonitorDisk }



constructor TSynMonitorDisk.Create;

begin

  fAvailableSize := TSynMonitorOneSize.Create;

  fFreeSize := TSynMonitorOneSize.Create;

  fTotalSize := TSynMonitorOneSize.Create;

end;



destructor TSynMonitorDisk.Destroy;

begin

  fAvailableSize.Free;

  fFreeSize.Free;

  fTotalSize.Free;

  inherited;

end;



function TSynMonitorDisk.GetName: RawUTF8;

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;

begin

  with TSynMonitorDisk.Create do

  try

    FormatUTF8('% % / %',[Name,FreeSize.Text,TotalSize.Text],result);

  finally

    Free;

  end;

end;



{$ifdef MSWINDOWS}

function GetDiskFreeSpaceExA(lpDirectoryName: PAnsiChar;

  var lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes,

  lpTotalNumberOfFreeBytes: QWord): LongBool; stdcall; external kernel32;

{$endif}



procedure TSynMonitorDisk.RetrieveDiskInfo;

  procedure RetrieveInfo;

  {$ifdef MSWINDOWS}

  var tmp: array[byte] of AnsiChar;

      dummy,flags: DWORD;

      dn: RawUTF8;

  begin

    if fName='' then

      fName := UpperCase(StringToUTF8(ExtractFileDrive(GetCurrentDir)));

    dn := fName;

    if (dn<>'') and (dn[2]=':') and (dn[3]=#0) then

      dn := dn+'\';

    if fVolumeName='' then begin

      tmp[0] := #0;

      GetVolumeInformationA(pointer(dn),tmp,sizeof(tmp),nil,dummy,flags,nil,0);

      SetString(fVolumeName,PAnsiChar(@tmp),StrLen(@tmp));

    end;

    GetDiskFreeSpaceExA(pointer(dn),PQWord(@fAvailableSize.fBytes)^,

      PQWord(@fTotalSize.fBytes)^,PQWord(@fFreeSize.fBytes)^);

  {$else}

  {$ifdef KYLIX3}

  var fs: TStatFs64;

      h: THandle;

  begin

    if fName='' then

      fName := '.';

    h := FileOpen(fName,fmShareDenyNone);

    fstatfs64(h,fs);

    FileClose(h);

    fAvailableSize.fBytes := fs.f_bavail*fs.f_bsize;

    fFreeSize.fBytes := fAvailableSize.fBytes;

    fTotalSize.fBytes := fs.f_blocks*fs.f_bsize;

  {$endif}

  {$ifdef FPC}

  var fs: pstatfs;

  begin

    if fName='' then

      fName := '.';

    fpStatFS(fName,fs);

    fAvailableSize.fBytes := QWord(fs.bavail)*QWord(fs.bsize);

    fFreeSize.fBytes := fAvailableSize.fBytes;

    fTotalSize.fBytes := QWord(fs.blocks)*QWord(fs.bsize);

  {$endif}

  {$endif}

  end;

var tix: cardinal;

begin

  tix := GetTickCount64 shr 7; // allow 128 ms resolution for updates

  if fLastDiskInfoRetrievedTix<>tix then begin

    fLastDiskInfoRetrievedTix := tix;

    RetrieveInfo;

  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 MSWINDOWS}

{$ifndef DELPHI5OROLDER}



{ TSynFPUException }



function TSynFPUException.VirtualAddRef: integer;

begin

  if fRefCount=0 then begin

    fSaved8087 := Get8087CW;

    Set8087CW(fExpected8087); // set FPU exceptions mask

  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

    Set8087CW(fSaved8087);

  result := 1; // should never be 0 (mark release of TSynFPUException instance)

end;



threadvar

  GlobalSynFPUExceptionDelphi,

  GlobalSynFPUExceptionLibrary: TSynFPUException;



constructor TSynFPUException.Create(Expected8087Flag: word);

begin // $1332=Delphi $133F=library (mask all exceptions)

  inherited Create;

  fExpected8087 := Expected8087Flag;

end;



class function TSynFPUException.ForLibraryCode: IUnknown;

begin

  if GlobalSynFPUExceptionLibrary=nil then begin

    GlobalSynFPUExceptionLibrary := TSynFPUException.Create($133F);

    GarbageCollector.Add(GlobalSynFPUExceptionLibrary);

  end;

  result := GlobalSynFPUExceptionLibrary;

end;



class function TSynFPUException.ForDelphiCode: IUnknown;

begin

  if GlobalSynFPUExceptionDelphi=nil then begin

    GlobalSynFPUExceptionDelphi := TSynFPUException.Create($1332);

    GarbageCollector.Add(GlobalSynFPUExceptionDelphi);

  end;

  result := GlobalSynFPUExceptionDelphi;

end;



{$endif DELPHI5OROLDER}

{$endif MSWINDOWS}





{ TAutoFree }



constructor TAutoFree.Create(var localVariable; obj: TObject);

begin

  fObject := obj;

  TObject(localVariable) := obj;

end;



class function TAutoFree.One(var localVariable; obj: TObject): IAutoFree;

begin

  result := Create(localVariable,obj);

end;



class function TAutoFree.Several(const varObjPairs: array of pointer): IAutoFree;

begin

  result := Create(varObjPairs);

end;



constructor TAutoFree.Create(const varObjPairs: array of pointer);

var n,i: integer;

begin

  n := length(varObjPairs);

  if (n=0) or (n and 1=1) then

    exit;

  n := n shr 1;

  if n=0 then

    exit;

  SetLength(fObjectList,n);

  for i := 0 to n-1 do begin

    fObjectList[i] := varObjPairs[i*2+1];

    PPointer(varObjPairs[i*2])^ := fObjectList[i];

  end;

end;



procedure TAutoFree.Another(var localVariable; obj: TObject);

var n: integer;

begin

  n := length(fObjectList);

  SetLength(fObjectList,n+1);

  fObjectList[n] := obj;

  TObject(localVariable) := obj;

end;



destructor TAutoFree.Destroy;

var i: integer;

begin

  if fObjectList<>nil then

    for i := high(fObjectList) downto 0 do // release FILO

      fObjectList[i].Free;

  fObject.Free;

  inherited;

end;





{ TAutoLocker }



constructor TAutoLocker.Create;

begin

  fSafe.Init;

end;



destructor TAutoLocker.Destroy;

begin

  fSafe.Done;

  inherited;

end;



function TAutoLocker.ProtectMethod: IUnknown;

begin

  result := TAutoLock.Create(@fSafe);

end;



procedure TAutoLocker.Enter;

begin

  EnterCriticalSection(fSafe.fSection);

end;



procedure TAutoLocker.Leave;

begin

  LeaveCriticalSection(fSafe.fSection);

end;



function TAutoLocker.Safe: PSynLocker;

begin

  result := @fSafe;

end;



{$ifndef DELPHI5OROLDER} // internal error C3517 under Delphi 5 :(

{$ifndef NOVARIANTS}



{ TLockedDocVariant }



constructor TLockedDocVariant.Create;

begin

  Create(JSON_OPTIONS_FAST);

end;



constructor TLockedDocVariant.Create(FastStorage: boolean);

begin

  Create(JSON_OPTIONS[FastStorage]);

end;



constructor TLockedDocVariant.Create(options: TDocVariantOptions);

begin

  fLock := TAutoLocker.Create;

  fValue.Init(options);

end;



destructor TLockedDocVariant.Destroy;

begin

  inherited;

  fLock.Free;

end;



function TLockedDocVariant.Exists(const Name: RawUTF8; out Value: Variant): boolean;

var i: integer;

begin

  fLock.Enter;

  try

    i := fValue.GetValueIndex(Name);

    if i<0 then

      result := false else begin

      Value := fValue.Values[i];

      result := true;

    end;

  finally

    fLock.Leave;

  end;

end;



function TLockedDocVariant.ExistsOrLock(const Name: RawUTF8; out Value: Variant): boolean;

var i: integer;

begin

  result := true;

  fLock.Enter;

  try

    i := fValue.GetValueIndex(Name);

    if i<0 then

      result := false else

      Value := fValue.Values[i];

  finally

    if result then

      fLock.Leave;

  end;

end;



procedure TLockedDocVariant.ReplaceAndUnlock(

  const Name: RawUTF8; const Value: Variant; out LocalValue: Variant);

begin

  try

    SetValue(Name,Value);

    LocalValue := Value;

  finally

    fLock.Leave;

  end;

end;



function TLockedDocVariant.AddExistingPropOrLock(const Name: RawUTF8;

  var Obj: variant): boolean;

var i: integer;

begin

  result := true;

  fLock.Enter;

  try

    i := fValue.GetValueIndex(Name);

    if i<0 then

      result := false else

      _ObjAddProps([Name,fValue.Values[i]],Obj);

  finally

    if result then

      fLock.Leave;

  end;

end;



procedure TLockedDocVariant.AddNewPropAndUnlock(const Name: RawUTF8;

  const Value: variant;

  var Obj: variant);

begin

  try

    SetValue(Name,Value);

    _ObjAddProps([Name,Value],Obj);

  finally

    fLock.Leave;

  end;

end;



function TLockedDocVariant.AddExistingProp(const Name: RawUTF8;

  var Obj: variant): boolean;

var i: integer;

begin

  result := true;

  fLock.Enter;

  try

    i := fValue.GetValueIndex(Name);

    if i<0 then

      result := false else

      _ObjAddProps([Name,fValue.Values[i]],Obj);

  finally

    fLock.Leave;

  end;

end;



procedure TLockedDocVariant.AddNewProp(const Name: RawUTF8;

  const Value: variant;

  var Obj: variant);

begin

  fLock.Enter;

  try

    SetValue(Name,Value);

    _ObjAddProps([Name,Value],Obj);

  finally

    fLock.Leave;

  end;

end;



function TLockedDocVariant.GetValue(const Name: RawUTF8): Variant;

begin

  fLock.Enter;

  try

    fValue.RetrieveValueOrRaiseException(pointer(Name),length(Name),

      dvoNameCaseSensitive in fValue.Options,result,false);

  finally

    fLock.Leave;

  end;

end;



procedure TLockedDocVariant.SetValue(const Name: RawUTF8;

  const Value: Variant);

begin

  fLock.Enter;

  try

    fValue.AddOrUpdateValue(Name,Value);

  finally

    fLock.Leave;

  end;

end;



procedure TLockedDocVariant.AddItem(const Value: variant);

begin

  fLock.Enter;

  try

    fValue.AddItem(Value);

  finally

    fLock.Leave;

  end;

end;



function TLockedDocVariant.Copy: variant;

begin

  VarClear(result);

  fLock.Enter;

  try

    TDocVariantData(result).InitCopy(variant(fValue),JSON_OPTIONS_FAST);

  finally

    fLock.Leave;

  end;

end;



procedure TLockedDocVariant.Clear;

var opt: TDocVariantOptions;

begin

  fLock.Enter;

  try

    opt := fValue.Options;

    fValue.Clear;

    fValue.Init(opt);

  finally

    fLock.Leave;

  end;

end;



function TLockedDocVariant.ToJSON(HumanReadable: boolean): RawUTF8;

var tmp: RawUTF8;

begin

  fLock.Enter;

  try

    VariantSaveJSON(variant(fValue),twJSONEscape,tmp);

  finally

    fLock.Leave;

  end;

  if HumanReadable then

    JSONBufferReformat(pointer(tmp),result) else

    result := tmp;

end;



{$endif NOVARIANTS}

{$endif DELPHI5OROLDER}





function GetDelphiCompilerVersion: RawUTF8;

begin

  result :=

{$ifdef FPC}

  'Free Pascal'

  {$ifdef VER2_6_4}+' 2.6.4'{$endif}

  {$ifdef VER2_7_0}+' 2.7.0'{$endif}

  {$ifdef VER2_7_1}+' 2.7.1'{$endif}

  {$ifdef VER3_0_1}+' 3.0.1'{$endif}

  {$ifdef VER3_1_1}+' 3.1.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'

    {$ifend}

  {$endif CONDITIONALEXPRESSIONS}

{$endif}

{$ifdef CPU64}

  +' 64 bit'

{$endif}

end;





{ TSynCache }



procedure TSynCache.Add(const aValue: RawUTF8; aTag: PtrInt);

begin

  if (self=nil) or (fFindLastAddedIndex<0) then

    // fFindLastAddedIndex should have been set by a previous call to Find()

    exit;

  inc(fValueSize,length(aValue));

  if fValueSize>fMaxCacheRamUsed then begin

    // if tends to consume too much memory, restart caching (fast in practice)

    Reset;

    exit;

  end;

  // add the cache entry values (text+integer)

  with fNameValue.List[fFindLastAddedIndex] do begin

    Tag := aTag;

    Value := aValue;

  end;

  fFindLastAddedIndex := -1;

end;



constructor TSynCache.Create(aMaxCacheRamUsed: cardinal=16384*1024; aCaseSensitive: boolean=false);

begin

  fNameValue.Init(aCaseSensitive);

  fNameValue.fDynArray.Capacity := 200; // some space for future cached entries

  fMaxCacheRamUsed := aMaxCacheRamUsed;

  fFindLastAddedIndex := -1;

end;



function TSynCache.Find(const aKey: RawUTF8; aResultTag: PPtrInt): RawUTF8;

var added: boolean;

begin

  result := '';

  if Self<>nil then

    if aKey='' then

      fFindLastAddedIndex := -1 else begin

      fFindLastAddedIndex := fNameValue.fDynArray.FindHashedForAdding(aKey,added);

      if added then

        fNameValue.List[fFindLastAddedIndex].Name := aKey else

        // match key found

        with fNameValue.List[fFindLastAddedIndex] do begin

          result := Value;

          if aResultTag<>nil then

            aResultTag^ := Tag;

          fFindLastAddedIndex := -1;

        end;

    end;

end;



function TSynCache.Reset: boolean;

begin

  result := false;

  if self=nil then

    exit; // avoid GPF

  if Count<>0 then begin

    if fValueSize<131072 then // no capacity change for small cache content

      fNameValue.Count := 0 else

      with fNameValue.fDynArray{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do begin

        Capacity := 0;   // force free all fNameValue.List[] key/value pairs

        Capacity := 200; // then reserve some space for future cached entries

      end;

    fNameValue.fDynArray.fHashs := nil; // will force reset all hash content

    result := true; // mark something was flushed

  end;

  fFindLastAddedIndex := -1;

  fValueSize := 0;

end;



{$ifdef VER220}

function TSynCache.Count: integer;

begin

  result := fNameValue.Count;

end;

{$endif}





{ TRawUTF8List }



function TRawUTF8List.Add(const aText: RawUTF8): PtrInt;

var capacity: PtrInt;

begin

  if self=nil then

    result := -1 else

    if fObjects=nil then begin

      capacity := length(fList);

      result := fCount;

      if result>=capacity then begin

        inc(capacity,256+fCount shr 3);

        SetLength(fList,capacity);

      end;

      fList[result] := aText;

      inc(fCount);

      Changed;

    end else

    result := AddObject(aText,nil);

end;



function TRawUTF8List.AddIfNotExisting(const aText: RawUTF8; wasAdded: PBoolean): PtrInt;

begin

  result := IndexOf(aText);

  if result<0 then begin

    result := Add(aText);

    if wasAdded<>nil then

      wasAdded^ := true;

  end else

    if wasAdded<>nil then

      wasAdded^ := false;

end;



function TRawUTF8List.AddObjectIfNotExisting(const aText: RawUTF8; aObject: TObject;

  wasAdded: PBoolean): PtrInt;

begin

  result := IndexOf(aText);

  if result<0 then begin

    result := AddObject(aText,aObject);

    if wasAdded<>nil then

      wasAdded^ := true;

  end else

    if wasAdded<>nil then

      wasAdded^ := false;

end;



function TRawUTF8List.AddObject(const aText: RawUTF8; aObject: TObject): PtrInt;

var capacity: PtrInt;

begin

  if self=nil then begin

    result := -1;

    exit;

  end;

  capacity := length(fList);

  result := fCount;

  if result>=capacity then begin

    inc(capacity,256+fCount shr 3);

    SetLength(fList,capacity);

    if (fObjects<>nil) or (aObject<>nil) then

      SetLength(fObjects,capacity);

  end else

    if (aObject<>nil) and (fObjects=nil) then

      SetLength(fObjects,capacity);

  fList[result] := aText;

  if aObject<>nil then

    fObjects[result] := aObject;

  inc(fCount);

  Changed;

end;



procedure TRawUTF8List.AddRawUTF8List(List: TRawUTF8List);

var i: PtrInt;

begin

  if List<>nil then begin

    BeginUpdate;

    if List.fObjects=nil then

      for i := 0 to List.fCount-1 do

        Add(List.fList[i]) else

      for i := 0 to List.fCount-1 do

        AddObject(List.fList[i],List.fObjects[i]);

    EndUpdate;

  end;

end;



procedure TRawUTF8List.BeginUpdate;

begin

  inc(fOnChangeLevel);

  if fOnChangeLevel>1 then

    exit;

  fOnChangeHidden := fOnChange;

  fOnChange := OnChangeHidden;

  fOnChangeTrigerred := false;

end;



procedure TRawUTF8List.Changed;

begin

  if (self<>nil) and Assigned(fOnChange) then

    fOnChange(self);

end;



procedure TRawUTF8List.Clear;

begin

  Capacity := 0;

  Changed;

end;



constructor TRawUTF8List.Create(aOwnObjects: boolean);

begin

  fNameValueSep := '=';

  fObjectsOwned := aOwnObjects;

  fCaseSensitive := true;

end;



destructor TRawUTF8List.Destroy;

begin

  Capacity := 0;

  inherited;

end;



procedure TRawUTF8List.Delete(Index: PtrInt);

begin

  if (self=nil) or (PtrUInt(Index)>=PtrUInt(fCount)) then

    exit;

  // release string/object instances

  fList[Index] := '';

  if (fObjects<>nil) and fObjectsOwned then

    FreeAndNil(fObjects[Index]);

  // swap the string/object arrays

  dec(fCount);

  if Index<fCount then begin

    MoveFast(fList[Index+1],fList[Index],(fCount-Index)*sizeof(fList[0]));

    PPointer(@fList[fCount])^ := nil; // avoid GPF

    if fObjects<>nil then begin

      MoveFast(fObjects[Index+1],fObjects[Index],(fCount-Index)*sizeof(fObjects[0]));

      fObjects[fCount] := nil; // avoid GPF if fObjectsOwned is set

    end;

  end;

  Changed;

end;



function TRawUTF8List.Delete(const aText: RawUTF8): PtrInt;

begin

  Result := IndexOf(aText);

  if Result>=0 then

    Delete(Result);

end;



function TRawUTF8List.DeleteFromName(const Name: RawUTF8): PtrInt;

begin

  Result := IndexOfName(Name);

  if Result>=0 then

    Delete(Result);

end;



procedure TRawUTF8List.EndUpdate;

begin

  if fOnChangeLevel<=0 then

    exit;

  dec(fOnChangeLevel);

  if fOnChangeLevel>0 then

    exit; // allows nested BeginUpdate..EndUpdate calls

  fOnChange := fOnChangeHidden;

  if fOnChangeTrigerred and Assigned(fOnChange) then

    fOnChange(self);

  fOnChangeTrigerred := false;

end;



function TRawUTF8List.Get(Index: PtrInt): RawUTF8;

begin

  if (self=nil) or (PtrUInt(Index)>=PtrUInt(fCount)) then

    result := '' else

    result := fList[Index];

end;



function TRawUTF8List.GetCapacity: PtrInt;

begin

  if self=nil then

    result := 0 else

    result := length(fList);

end;



function TRawUTF8List.GetCount: PtrInt;

begin

  if self=nil then

    result := 0 else

    result := fCount;

end;



function TRawUTF8List.GetListPtr: PPUtf8CharArray;

begin

  if self=nil then

    result := nil else

    result := pointer(fList);

end;



function TRawUTF8List.GetObjectPtr: PPointerArray;

begin

  if self=nil then

    result := nil else

    result := pointer(fObjects);

end;



function TRawUTF8List.GetName(Index: PtrInt): RawUTF8;

var Sep: PUTF8Char;

begin

  result := Get(Index);

  if result='' then

    exit;

  Sep := PosChar(pointer(result),NameValueSep);

  if Sep=nil then

    result := '' else

    SetLength(result,Sep-pointer(result));

end;



function TRawUTF8List.GetObject(Index: PtrInt): TObject;

begin

  if (self<>nil) and (PtrUInt(Index)<PtrUInt(fCount)) and (fObjects<>nil) then

    result := fObjects[Index] else

    result := nil;

end;



function TRawUTF8List.GetObjectByName(const Name: RawUTF8): TObject;

var ndx: PtrUInt;

begin

  if (self<>nil) and (fObjects<>nil) then begin

    ndx := IndexOf(Name);

    if ndx<PtrUInt(fCount) then begin

      result := fObjects[ndx];

      exit;

    end else begin

      result := nil;

      exit;

    end;

  end else begin

    result := nil;

    exit;

  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;

  DelimLen := length(Delimiter);

  Len := DelimLen*(fCount-1);

  for i := 0 to fCount-1 do

    inc(Len,length(fList[i]));

  SetLength(result,len);

  P := pointer(result);

  i := 0;

  repeat

    Len := length(fList[i]);

    if Len>0 then begin

      MoveFast(pointer(fList[i])^,P^,Len);

      inc(P,Len);

    end;

    inc(i);

    if i>=fCount then

      Break;

    MoveFast(pointer(Delimiter)^,P^,DelimLen);

    inc(P,DelimLen);

  until false;

end;



procedure TRawUTF8List.SaveToStream(Dest: TStream; const Delimiter: RawUTF8);

var W: TTextWriter;

    i: integer;

begin

  if (self=nil) or (fCount=0) then

    exit;

  W := TTextWriter.Create(Dest,8192); // faster with a 8KB intermediate buffer

  try

    i := 0;

    repeat

      W.AddString(fList[i]);

      inc(i);

      if i>=fCount then

        Break;

      W.AddString(Delimiter);

    until false;

    W.FlushFinal;

  finally

    W.Free;

  end;

end;



procedure TRawUTF8List.SaveToFile(const FileName: TFileName; const Delimiter: RawUTF8);

var FS: TFileStream;

begin

  FS := TFileStream.Create(FileName,fmCreate);

  try

    SaveToStream(FS,Delimiter);

  finally

    FS.Free;

  end;

end;



function TRawUTF8List.GetTextCRLF: RawUTF8;

begin

  result := GetText;

end;



function TRawUTF8List.GetValue(const Name: RawUTF8): RawUTF8;

begin

  Result := GetValueAt(IndexOfName(Name));

end;



function TRawUTF8List.GetValueAt(Index: PtrInt): RawUTF8;

var Sep: PUTF8Char;

begin

  if (self=nil) or (PtrUInt(Index)>=PtrUInt(fCount)) then

    result := '' else

    result := Get(Index);

  if result='' then

    exit;

  Sep := PosChar(pointer(result),NameValueSep);

  if Sep=nil then

    result := '' else

    result := Sep+1; // get 'Value' from 'Name=Value'

end;



function TRawUTF8List.IndexOf(const aText: RawUTF8): PtrInt;

begin

  if self<>nil then

    if fCaseSensitive then begin

      for result := 0 to fCount-1 do

        if fList[result]=aText then

          exit;

    end else

      for result := 0 to fCount-1 do

        if UTF8IComp(pointer(fList[result]),pointer(aText))=0 then

          exit;

  result := -1;

end;



function TRawUTF8List.IndexOfName(const Name: RawUTF8): PtrInt;

var UpperName: array[byte] of AnsiChar;

begin

  if self<>nil then begin

    PWord(UpperCopy255(UpperName,Name))^ := ord(NameValueSep);

    for result := 0 to fCount-1 do

      if IdemPChar(Pointer(fList[result]),UpperName) then

        exit;

  end;

  result := -1;

end;



function TRawUTF8List.IndexOfObject(aObject: TObject): PtrInt;

begin

  if (self<>nil) and (fObjects<>nil) then

    result := PtrUIntScanIndex(pointer(fObjects),fCount,PtrUInt(aObject)) else

    result := -1;

end;



procedure TRawUTF8List.OnChangeHidden(Sender: TObject);

begin

  if self<>nil then

    fOnChangeTrigerred := true;

end;



procedure TRawUTF8List.Put(Index: PtrInt; const Value: RawUTF8);

begin

  if (self<>nil) and (PtrUInt(Index)<PtrUInt(fCount)) then begin

    fList[Index] := Value;

    Changed;

  end;

end;



procedure TRawUTF8List.PutObject(Index: PtrInt; const Value: TObject);

begin

  if (self<>nil) and (PtrUInt(Index)<PtrUInt(fCount)) then begin

    if fObjects=nil then

      SetLength(fObjects,Length(fList));

    fObjects[Index] := Value;

    Changed;

  end;

end;



procedure TRawUTF8List.SetCapacity(const Value: PtrInt);

var i: integer;

begin

  if self<>nil then begin

    if Value<=0 then begin

      fList := nil;

      if fObjects<>nil then begin

        if fObjectsOwned then

          for i := 0 to fCount-1 do

            fObjects[i].Free;

        fObjects := nil;

      end;

      fCount := 0;

    end else begin

      if Value<fCount then begin

        if (fObjects<>nil) and fObjectsOwned then

          for i := Value to fCount-1 do

            FreeAndNil(fObjects[i]);

        fCount := Value;

      end;

      if Value>length(fList) then begin // increase capacity

        SetLength(fList,Value);

        if pointer(fObjects)<>nil then

          SetLength(fObjects,Value);

      end;

    end;

  end;

end;



procedure TRawUTF8List.SetText(const aText, Delimiter: RawUTF8);

begin

  SetTextPtr(pointer(aText),Delimiter);

end;



procedure TRawUTF8List.LoadFromFile(const FileName: TFileName);

var Map: TMemoryMap;

    P: pointer;

begin

  if Map.Map(FileName) then

  try

    if Map.Size<>0 then begin

      if TextFileKind(Map)=isUTF8 then // ignore UTF-8 BOM

        P := Map.Buffer+3 else

        P := Map.Buffer;

      SetTextPtr(P,#13#10);

    end;

  finally

    Map.UnMap;

  end;

end;



procedure TRawUTF8List.SetTextPtr(P: PUTF8Char; const Delimiter: RawUTF8);

var DelimLen: PtrInt;

    DelimFirst: AnsiChar;

    PBeg, DelimNext: PUTF8Char;

    Line: RawUTF8;

begin

  DelimLen := length(Delimiter);

  BeginUpdate;

  Clear;

  if (P<>nil) and (DelimLen>0) then begin

    DelimFirst := Delimiter[1];

    DelimNext := PUTF8Char(pointer(Delimiter))+1;

    repeat

      PBeg := P;

      while P^<>#0 do begin

        if (P^=DelimFirst) and CompareMem(P+1,DelimNext,DelimLen-1) then

          break;

        inc(P);

      end;

      SetString(Line,PBeg,P-PBeg);

      AddObject(Line,nil);

      if P^=#0 then

        break;

      inc(P,DelimLen);

    until P^=#0;

  end;

  EndUpdate;

end;



procedure TRawUTF8List.SetTextCRLF(const Value: RawUTF8);

begin

  SetTextPtr(pointer(Value),#13#10);

end;



procedure TRawUTF8List.SetValue(const Name, Value: RawUTF8);

var i: PtrInt;

begin

  i := IndexOfName(Name);

  if i<0 then

    Add(Name+RawUTF8(NameValueSep)+Value) else

    fList[i] := Name+RawUTF8(NameValueSep)+Value;

end;



procedure TRawUTF8List.SetCaseSensitive(Value: boolean);

begin

  fCaseSensitive := Value;

end;



procedure TRawUTF8List.UpdateValue(const Name: RawUTF8; var Value: RawUTF8;

  ThenDelete: boolean);

var i: PtrInt;

begin

  i := IndexOfName(Name);

  if i>=0 then begin

    Value := GetValueAt(i); // update value

    if ThenDelete then

      Delete(i); // optionally delete

  end;

end;



function TRawUTF8List.PopFirst(out aText: RawUTF8; aObject: PObject=nil): boolean;

begin

  result := fCount>0;

  if not result then

    exit;

  aText := fList[0];

  if aObject<>nil then

    if fObjects<>nil then

      aObject^ := fObjects[0] else

      aObject^ := nil;

  Delete(0);

end;



function TRawUTF8List.PopLast(out aText: RawUTF8; aObject: PObject=nil): boolean;

var ndx: integer;

begin

  result := fCount>0;

  if not result then

    exit;

  ndx := fCount-1;

  aText := fList[ndx];

  if aObject<>nil then

    if fObjects<>nil then

      aObject^ := fObjects[ndx] else

      aObject^ := nil;

  Delete(ndx);

end;





{ TRawUTF8ListLocked }



constructor TRawUTF8ListLocked.Create(aOwnObjects: boolean);

begin

  inherited Create(aOwnObjects);

  fSafe.Init;

end;



destructor TRawUTF8ListLocked.Destroy;

begin

  inherited;

  fSafe.Done;

end;





{ TObjectListHashedAbstract}



constructor TObjectListHashedAbstract.Create(aFreeItems: boolean);

begin

  inherited Create;

  fFreeItems := aFreeItems;

  fHash.Init(TypeInfo(TObjectDynArray),fList,@HashPtrUInt,@SortDynArrayPointer,nil,@fCount);

  fHash.fHashCountTrigger := 0; // has dedicated inherited process of small lists 

end;



destructor TObjectListHashedAbstract.Destroy;

var i: integer;

begin

  if fFreeItems then

    for i := 0 to fCount-1 do

      List[i].Free;

  inherited;

end;



procedure TObjectListHashedAbstract.Delete(aIndex: integer);

begin

  if (self=nil) or (cardinal(aIndex)>=cardinal(fCount)) then

    exit;

  if fFreeItems then

    FreeAndNil(List[aIndex]);

  fHash.Delete(aIndex);

  fHashValid := false;

end;



procedure TObjectListHashedAbstract.Delete(aObject: TObject);

begin

  Delete(IndexOf(aObject));

end;







{ TObjectListHashed }



const

  // hashing will start only when List[] reaches 32 items (not worth it before)

  TOBJECTLISTHASHED_START_HASHING_COUNT = 32;



function TObjectListHashed.Add(aObject: TObject; out wasAdded: boolean): integer;

begin

  wasAdded := false;

  if self<>nil then

    if fHashed then begin

      if not fHashValid then

        fHashValid := fHash.ReHash;

      result := fHash.FindHashedForAdding(aObject,wasAdded);

      if wasAdded then

        fList[result] := aObject;

    end else begin

      for result := 0 to fCount-1 do

        if fList[result]=aObject then

          exit;

      wasAdded := true;

      result := fHash.Add(aObject);

      if fCount>=TOBJECTLISTHASHED_START_HASHING_COUNT then

        fHashed := true;

    end

  else

    result := -1;

end;



function TObjectListHashed.IndexOf(aObject: TObject): integer;

begin

  if (self<>nil) and (fCount>0) then

    if fHashed then begin

      if not fHashValid then begin

        fHash.ReHash;

        fHashValid := true;

      end;

      result := fHash.FindHashed(aObject);

      exit;

    end else

    for result := 0 to fCount-1 do

      if fList[result]=aObject then

        exit;

  result := -1;

end;





{ TObjectListPropertyHashed }



constructor TObjectListPropertyHashed.Create(

  aSubPropAccess: TObjectListPropertyHashedAccessProp;

  aHashElement: TDynArrayHashOne; aCompare: TDynArraySortCompare;

  aFreeItems: boolean);

begin

  inherited Create(aFreeItems);

  fSubPropAccess := aSubPropAccess;

  if Assigned(aHashElement) then

    fHash.fHashElement := aHashElement;

  if Assigned(aCompare) then

    fHash.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare := aCompare;

  fHash.EventCompare := IntComp;

end;



function TObjectListPropertyHashed.IntHash(const Elem): cardinal;

var O: TObject;

begin

  O := fSubPropAccess(TObject(Elem));

  result := fHash.fHashElement(O,fHash.fHasher);

end;



function TObjectListPropertyHashed.IntComp(const A,B): integer;

var O: TObject;

begin

  O := fSubPropAccess(TObject(A));

  result := fHash.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare(O,B);

end;



procedure TObjectListPropertyHashed.IntHashValid;

begin

  fHash.ReHash(IntHash);

  fHashValid := true;

end;



function TObjectListPropertyHashed.Add(aObject: TObject; out wasAdded: boolean): integer;

begin

  wasAdded := false;

  if self<>nil then

    if fHashed then begin

      if not fHashValid then

        IntHashValid;

      result := fHash.FindHashedForAdding(aObject,wasAdded,

        fHash.fHashElement(aObject,fHash.fHasher));

      if wasAdded then

        fList[result] := aObject;

    end else begin

      for result := 0 to fCount-1 do

        if IntComp(fList[result],aObject)=0 then

          exit;

      wasAdded := true;

      result := fHash.Add(aObject);

      if fCount>=TOBJECTLISTHASHED_START_HASHING_COUNT then

        fHashed := true;

    end

  else

    result := -1;

end;



function TObjectListPropertyHashed.IndexOf(aObject: TObject): integer;

begin

  if fCount>0 then

    if fHashed then begin

      if not fHashValid then

        IntHashValid;

      result := fHash.HashFind(fHash.fHashElement(aObject,fHash.fHasher),PtrInt(aObject));

      if result>=0 then

        exit; // if found

    end else

    for result := 0 to fCount-1 do

      if IntComp(fList[result],aObject)=0 then

        exit;

  result := -1;

end;





{ TPointerClassHashed }



constructor TPointerClassHashed.Create(aInfo: pointer);

begin

  fInfo := aInfo;

end;





{ TPointerClassHash }



function PointerClassHashProcess(aObject: TPointerClassHashed): pointer;

begin

  result := aObject.Info;

end;



constructor TPointerClassHash.Create;

begin

  inherited Create(@PointerClassHashProcess);

end;



function TPointerClassHash.TryAdd(aInfo: pointer): PPointerClassHashed;

var wasAdded: boolean;

    i: integer;

begin

  i := inherited Add(aInfo,wasAdded);

  if wasAdded then

    result := @List[i] else

    result := nil;

end;



function TPointerClassHash.Find(aInfo: pointer): TPointerClassHashed;

var i: integer;

begin

  if self<>nil then begin

    if not fHashed then begin // Count<TOBJECTLISTHASHED_START_HASHING_COUNT

      for i := 0 to fCount-1 do begin

        result := TPointerClassHashed(List[i]);

        if result.Info=aInfo then

          exit;

      end;

      result := nil;

    end else begin

      i := IndexOf(aInfo);

      if i>=0 then

        result := TPointerClassHashed(List[i]) else

        result := nil;

    end;

  end else

    result := nil;

end;





{ TPointerClassHashLocked }



constructor TPointerClassHashLocked.Create;

begin

  inherited Create;

  fSafe.Init;

end;



destructor TPointerClassHashLocked.Destroy;

begin

  fSafe.Done;

  inherited Destroy;

end;



function TPointerClassHashLocked.FindLocked(aInfo: pointer): TPointerClassHashed;

begin

  if self=nil then

    result := nil else begin

    fSafe.Lock;

    try

      result := inherited Find(aInfo);

    finally

      fSafe.UnLock;

    end;

  end;

end;



function TPointerClassHashLocked.TryAddLocked(aInfo: pointer;

  out aNewEntry: PPointerClassHashed): boolean;

var wasAdded: boolean;

    i: integer;

begin

  fSafe.Lock;

  i := inherited Add(aInfo,wasAdded);

  if wasAdded then begin

    aNewEntry := @List[i];

    result := true; // caller should call Unlock

  end else begin

    fSafe.UnLock;

    result := false;

  end;

end;



procedure TPointerClassHashLocked.Unlock;

begin

  fSafe.UnLock;

end;





{ TObjectListLocked }



constructor TObjectListLocked.Create(AOwnsObjects: Boolean=true);

begin

  inherited Create(AOwnsObjects);

  fSafe.Init;

end;



destructor TObjectListLocked.Destroy;

begin

  inherited Destroy;

  fSafe.Done;

end;





{ TRawUTF8ListHashed }



{$ifdef PUREPASCAL}

function SortDynArrayAnsiStringHashOnly(const A,B): integer;

begin

  if RawByteString(A)=RawByteString(B) then // faster than StrCmp

    result := 0 else

    result := 1; // fake comparison, but fHash only use equality

end;

{$endif}



var

  DYNARRAY_SORTFIRSTFIELDHASHONLY: array[boolean] of TDynArraySortCompare = (

    SortDynArrayAnsiStringI,

    {$ifdef PUREPASCAL}SortDynArrayAnsiStringHashOnly

    {$else}SortDynArrayAnsiString{$endif});



constructor TRawUTF8ListHashed.Create(aOwnObjects: boolean);

begin

  inherited Create(aOwnObjects);

  fHash.Init(TypeInfo(TRawUTF8DynArray),fList,@HashAnsiString,

    DYNARRAY_SORTFIRSTFIELDHASHONLY[true],nil,@fCount);

end;



procedure TRawUTF8ListHashed.Changed;

begin

  fChanged := true;

  inherited;

end;



procedure TRawUTF8ListHashed.SetCaseSensitive(Value: boolean);

begin

  if fCaseSensitive=Value then

    exit;

  inherited;

  fHash.fHashElement := DYNARRAY_HASHFIRSTFIELD[not Value,djRawUTF8];

  fHash.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare :=

    DYNARRAY_SORTFIRSTFIELDHASHONLY[Value];

  if not fChanged then

    fChanged := Count>0; // force re-hash next IndexOf() call

end;



function TRawUTF8ListHashed.IndexOf(const aText: RawUTF8): PtrInt;

begin

  if fChanged then

    fChanged := not fHash.ReHash; // rough, but working implementation

  result := fHash.FindHashed(aText);

end;



function TRawUTF8ListHashed.AddIfNotExisting(const aText: RawUTF8;

  wasAdded: PBoolean): PtrInt;

var added: boolean;

begin

  if fChanged then

    fChanged := not fHash.ReHash; // rough, but working implementation

  result := fHash.FindHashedForAdding(aText,added);

  if added then begin

    fList[result] := aText;

    if (fObjects<>nil) and (length(fObjects)<>length(fList)) then

      SetLength(fObjects,length(fList));

  end;

  if wasAdded<>nil then

    wasAdded^ := added;

end;



function TRawUTF8ListHashed.AddObjectIfNotExisting(

  const aText: RawUTF8; aObject: TObject; wasAdded: PBoolean): PtrInt;

var added: boolean;

begin

  if fChanged then

    fChanged := not fHash.ReHash; // rough, but working implementation

  result := fHash.FindHashedForAdding(aText,added);

  if added then begin

    fList[result] := aText;

    if length(fObjects)<>length(fList) then

      SetLength(fObjects,length(fList));

    fObjects[result] := aObject;

  end;

  if wasAdded<>nil then

    wasAdded^ := added;

end;



function TRawUTF8ListHashed.HashFind(aHashCode: cardinal): integer;

begin

  result := fHash.HashFind(aHashCode);

end;





{ TRawUTF8ListHashedLocked }



constructor TRawUTF8ListHashedLocked.Create(aOwnObjects: boolean);

begin

  inherited Create(aOwnObjects);

  fSafe.Init;

end;



destructor TRawUTF8ListHashedLocked.Destroy;

begin

  fSafe.Done;

  inherited;

end;



function TRawUTF8ListHashedLocked.LockedAdd(const aText: RawUTF8): PtrInt;

begin

  fSafe.Lock;

  try

    result := inherited Add(aText);

  finally

    fSafe.UnLock;

  end;

end;



function TRawUTF8ListHashedLocked.IndexOf(const aText: RawUTF8): PtrInt;

begin

  fSafe.Lock;

  try

    result := inherited IndexOf(aText);

  finally

    fSafe.UnLock;

  end;

end;



function TRawUTF8ListHashedLocked.LockedGetObjectByName(const aText: RawUTF8): TObject;

begin

  fSafe.Lock;

  try

    result := inherited GetObjectByName(aText);

  finally

    fSafe.UnLock;

  end;

end;



function TRawUTF8ListHashedLocked.AddIfNotExisting(const aText: RawUTF8;

  wasAdded: PBoolean): PtrInt;

begin

  fSafe.Lock;

  try

    result := inherited AddIfNotExisting(aText,wasAdded);

  finally

    fSafe.UnLock;

  end;

end;



function TRawUTF8ListHashedLocked.AddObjectIfNotExisting(const aText: RawUTF8;

  aObject: TObject; wasAdded: PBoolean): PtrInt;

begin

  fSafe.Lock;

  try

    result := inherited AddObjectIfNotExisting(aText,aObject,wasAdded);

  finally

    fSafe.UnLock;

  end;

end;



function TRawUTF8ListHashedLocked.Delete(const aText: RawUTF8): PtrInt;

begin

  fSafe.Lock;

  try

    result := inherited IndexOf(aText);

    if result>=0 then

      inherited Delete(result);

  finally

    fSafe.UnLock;

  end;

end;



function TRawUTF8ListHashedLocked.DeleteFromName(const Name: RawUTF8): PtrInt;

begin

  fSafe.Lock;

  try

    result := inherited IndexOfName(Name);

    if result>=0 then

      inherited Delete(result);

  finally

    fSafe.UnLock;

  end;

end;



function TRawUTF8ListHashedLocked.PopFirst(out aText: RawUTF8; aObject: PObject=nil): boolean;

begin

  fSafe.Lock;

  try

    result := inherited PopFirst(aText,aObject);

  finally

    fSafe.UnLock;

  end;

end;



function TRawUTF8ListHashedLocked.PopLast(out aText: RawUTF8; aObject: PObject=nil): boolean;

begin

  fSafe.Lock;

  try

    result := inherited PopLast(aText,aObject);

  finally

    fSafe.UnLock;

  end;

end;



procedure TRawUTF8ListHashedLocked.Clear;

begin

  fSafe.Lock;

  try

    inherited Clear;

  finally

    fSafe.UnLock;

  end;

end;





{ TRawUTF8MethodList }



function TRawUTF8MethodList.AddEvent(const aName: RawUTF8;

  const aEvent: TMethod): PtrInt;

begin

  result := Add(aName);

  if result>=length(fEvents) then

    SetLength(fEvents,result+256);

  fEvents[result] := aEvent;

end;



procedure TRawUTF8MethodList.Clear;

begin

  inherited Clear;

  fEvents := nil;

end;



procedure TRawUTF8MethodList.Delete(Index: PtrInt);

begin

  inherited Delete(Index);

  if Index<length(fEvents) then

    MoveFast(fEvents[Index+1],fEvents[Index],(length(fEvents)-Index)*sizeof(TMethod));

end;



function TRawUTF8MethodList.GetEvent(aIndex: PtrInt;

  out aEvent: TMethod): boolean;

begin

  result := aIndex<length(fEvents);

  if result then

    aEvent := fEvents[aIndex];

end;



function TRawUTF8MethodList.GetEventByName(const aText: RawUTF8;

  out aEvent: TMethod): boolean;

var i: integer;

begin

  result := false;

  if self=nil then

    exit;

  i := IndexOf(aText);

  if (i>=0) and (i<length(fEvents)) then begin

    result := true;

    aEvent := fEvents[i];

  end;

end;







{ TSynDictionary }



const

  DIC_KEYCOUNT = 0;

  DIC_KEY = 1;

  DIC_VALUECOUNT = 2;

  DIC_VALUE = 3;

  

constructor TSynDictionary.Create(aKeyTypeInfo,aValueTypeInfo: pointer;

  aKeyCaseInsensitive: boolean);

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.PaddingMaxUsedIndex := DIC_VALUE;

  fKeys.Init(aKeyTypeInfo,fSafe.Padding[DIC_KEY].VAny,nil,nil,nil,

    @fSafe.Padding[DIC_KEYCOUNT].VInteger,aKeyCaseInsensitive);

  fValues.Init(aValueTypeInfo,fSafe.Padding[DIC_VALUE].VAny,

    @fSafe.Padding[DIC_VALUECOUNT].VInteger);

end;



procedure TSynDictionary.DeleteAll;

begin

  fSafe.Lock;

  try

    fKeys.Clear;

    fKeys.ReHash; // mandatory to avoid GPF

    fValues.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;

begin

  fSafe.Lock;

  try

    result := fKeys.FindHashedForAdding(aKey,added);

    if added then begin

      with fKeys{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do

        ElemCopy(aKey,ElemPtr(result)^); // fKey[result] := aKey;

      if fValues.Add(aValue)<>result then

        raise ESynException.CreateUTF8('%.Add fValues.Add',[self]);

    end else

      result := -1;

  finally

    fSafe.UnLock;

  end;

end;



function TSynDictionary.AddOrUpdate(const aKey, aValue): integer;

var added: boolean;

begin

  fSafe.Lock;

  try

    result := fKeys.FindHashedForAdding(aKey,added);

    if added then begin

      with fKeys{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do

        ElemCopy(aKey,ElemPtr(result)^); // fKey[result] := aKey;

      if fValues.Add(aValue)<>result then

        raise ESynException.CreateUTF8('%.AddOrUpdate fValues.Add',[self]);

    end else

      fValues.ElemCopy(aValue,fValues.ElemPtr(result)^);

  finally

    fSafe.UnLock;

  end;

end;



function TSynDictionary.Clear(const aKey): integer;

begin

  fSafe.Lock;

  try

    result := fKeys.FindHashed(aKey);

    if result>=0 then

      fValues.ElemClear(fValues.ElemPtr(result)^);

  finally

    fSafe.UnLock;

  end;

end;



function TSynDictionary.Delete(const aKey): integer;

begin

  fSafe.Lock;

  try

    result := fKeys.FindHashedAndDelete(aKey);

    if result>=0 then

      fValues.Delete(result);

  finally

    fSafe.UnLock;

  end;

end;



function TSynDictionary.InArray(const aKey, aArrayValue; aAction: TSynDictionaryInArray): Boolean;

var nested: TDynArray;

    ndx: integer;

begin

  result := false;

  if (fValues.ElemType=nil) or (PTypeKind(fValues.ElemType)^<>tkDynArray) then

    raise ESynException.CreateUTF8('%.Values: % items are not dynamic arrays',

      [self,PShortString(@PTypeInfo(fValues.ArrayType)^.NameLen)^]);

  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.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): integer;

begin // caller is expected to call fSafe.Lock/Unlock

  result := fKeys.FindHashed(aKey);

end;



function TSynDictionary.FindAndCopy(const aKey; out aValue): boolean;

var ndx: integer;

begin

  fSafe.Lock;

  try

    ndx := fKeys.FindHashed(aKey);

    if ndx>=0 then begin

      fValues.ElemCopy(fValues.ElemPtr(ndx)^,aValue);

      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;



function TSynDictionary.ForEach(const OnEach: TSynDictionaryEvent): integer;

var k,v: PAnsiChar;

    i,n,ks,vs: integer;

begin

  fSafe.Lock;

  try

    result := 0;

    n := fSafe.Padding[DIC_KEYCOUNT].VInteger;

    if (n=0) or not Assigned(OnEach) then

      exit;

    k := fKeys.fValue^;

    ks := fKeys.ElemSize;

    v := fValues.fValue^;

    vs := fValues.ElemSize;

    for i := 0 to n-1 do begin

      inc(result);

      if not OnEach(k^,v^,i,n) 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): 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.fValue^;

    ks := fKeys.ElemSize;

    v := fValues.fValue^;

    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) then

          break;

      end;

      inc(k,ks);

      inc(v,vs);

    end;

  finally

    fSafe.UnLock;

  end;

end;



function TSynDictionary.Count: integer;

begin

  {$ifdef NOVARIANTS}

  result := fSafe.Padding[DIC_KEYCOUNT].VInteger;

  {$else}

  result := fSafe.LockedInt64[DIC_KEYCOUNT];

  {$endif}

end;



procedure TSynDictionary.SaveToJSON(W: TTextWriter; EnumSetsAsText: boolean);

var k,v: RawUTF8;

begin

  fSafe.Lock;

  try

    k := fKeys.SaveToJSON(EnumSetsAsText);

    v := fValues.SaveToJSON(EnumSetsAsText);

  finally

    fSafe.UnLock;

  end;

  W.AddJSONArraysAsJSONObject(pointer(k),pointer(v));

end;



function TSynDictionary.SaveToJSON(EnumSetsAsText: boolean): RawUTF8;

var W: TTextWriter;

begin

  W := TTextWriter.CreateOwnedStream;

  try

    SaveToJSON(W,EnumSetsAsText);

    W.SetText(result);

  finally

    W.Free;

  end;

end;



function TSynDictionary.LoadFromJSON(const JSON: RawUTF8;

  EnsureNoKeyCollision: boolean): boolean;

begin

  result := LoadFromJSON(pointer(JSON),EnsureNoKeyCollision);

end;



function TSynDictionary.LoadFromJSON(JSON: PUTF8Char; EnsureNoKeyCollision: boolean): boolean;

var k,v: RawUTF8;

begin

  result := false;

  if not JSONObjectAsJSONArrays(JSON,k,v) then

    exit;

  fSafe.Lock;

  try

    if fKeys.LoadFromJSON(pointer(k))<>nil then

      if fValues.LoadFromJSON(pointer(v))<>nil then

        if fKeys.Count=fValues.Count then

          if EnsureNoKeyCollision then

            // fKeys.Rehash is not enough, since input JSON may be invalid

            result := fKeys.IsHashElementWithoutCollision<0 else begin

            // optimistic approach

            fKeys.Rehash;

            result := true;

          end;

  finally

    fSafe.UnLock;

  end;

end;



function TSynDictionary.LoadFromBinary(const binary: RawByteString): boolean;

var P: PAnsiChar;

begin

  result := false;

  P := pointer(SynLZDecompress(binary));

  if P=nil then

    exit;

  fSafe.Lock;

  try

    P := fKeys.LoadFrom(P);

    if P<>nil then

      P := fValues.LoadFrom(P);

    if (P<>nil) and (fKeys.Count=fValues.Count) then begin

      fKeys.ReHash; // optimistic: input from safe TSynDictionary.SaveToBinary

      result := true;

    end;

  finally

    fSafe.UnLock;

  end;

end;



function TSynDictionary.SaveToBinary: RawByteString;

var tmp: TSynTempBuffer;

begin

  fSafe.Lock;

  try

    tmp.Init(fKeys.SaveToLength+fValues.SaveToLength);

    if fValues.SaveTo(fKeys.SaveTo(tmp.buf))-tmp.buf<>tmp.len then

      result := '' else

      SynLZCompress(tmp.buf,tmp.len,result);

    tmp.Done;

  finally

    fSafe.UnLock;

  end;

end;





{ TMemoryMap }



function TMemoryMap.Map(aFile: THandle; aCustomSize: cardinal; 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) or (fFileSize>maxInt) then

    /// maxInt = $7FFFFFFF = 1.999 GB (2GB would induce PtrInt errors)

    exit;

  if aCustomSize=0 then

    fBufSize := Int64Rec(fFileSize).Lo else begin

    Available := fFileSize-aCustomOffset;

    if Available<0 then

      exit;

    if aCustomSize>Available then

      fBufSize := Int64Rec(Available).Lo;

      fBufSize := aCustomSize;

  end;

  {$ifdef MSWINDOWS}

  with Int64Rec(fFileSize) do

    fMap := CreateFileMapping(fFile,nil,PAGE_READONLY,Hi,Lo,nil);

  if fMap=0 then

    raise ESynException.Create('TMemoryMap.Map: CreateFileMapping()=0');

  with Int64Rec(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 (_SC_PAGE_SIZE-1)<>0 then

      raise ESynException.CreateUTF8('fpmmap(aCustomOffset=%) with pagesize=%',

        [aCustomOffset,_SC_PAGE_SIZE]) else

      aCustomOffset := aCustomOffset div _SC_PAGE_SIZE;

  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: cardinal);

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 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: integer);

begin

  inherited Create;

  SetPointer(Data,DataLen);

end;



function TSynMemoryStream.Write(const Buffer; Count: Integer): Longint;

begin

  raise EStreamError.Create('TSynMemoryStream.Write');

end;





{ TSynMemoryStreamMapped }



constructor TSynMemoryStreamMapped.Create(const aFileName: TFileName;

  aCustomSize: cardinal; 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: cardinal; aCustomOffset: Int64);

begin

  if not fMap.Map(aFile,aCustomSize,aCustomOffset) then

    raise ESynException.CreateUTF8('%.Create(%) mapping error',[self,fFileName]);

  inherited Create(fMap.fBuf,fMap.fBufSize);

end;



destructor TSynMemoryStreamMapped.Destroy;

begin

  fMap.UnMap;

  fFileStream.Free;

  inherited;

end;





function FileSeek64(Handle: THandle; const Offset: Int64; Origin: DWORD): Int64;

{$ifdef MSWINDOWS}

var R64: packed record Lo, Hi: integer; end absolute Result;

begin

  Result := Offset;

  R64.Lo := integer(SetFilePointer(Handle,R64.Lo,@R64.Hi,Origin));

  if (R64.Lo=-1) and (GetLastError<>0) then

    R64.Hi := -1; // so result=-1

end;

{$else}

begin

  {$ifdef FPC}

  result := FPLSeek(Handle,Offset,Origin);

  {$else}

  {$ifdef KYLIX3}

  result := LibC.lseek64(Handle,Offset,Origin);

  {$else}

  // warning: this won't handle file size > 2 GB :(

  result := FileSeek(Handle,Offset,Origin);

  {$endif}

  {$endif}

end;

{$endif}





{ TFileBufferWriter }



constructor TFileBufferWriter.Create(aFile: THandle; BufLen: integer);

begin

  Create(THandleStream.Create(aFile),BufLen);

  fInternalStream := true;

end;



constructor TFileBufferWriter.Create(const aFileName: TFileName; BufLen: integer;

  Append: boolean);

var s: TStream;

begin

  if Append and FileExists(aFileName) then begin

    s := TFileStream.Create(aFileName,fmOpenWrite);

    s.Seek(0,soFromEnd);

  end else

    s := TFileStream.Create(aFileName,fmCreate);

  Create(s,BufLen);

  fInternalStream := true;

end;



constructor TFileBufferWriter.Create(aStream: TStream; BufLen: integer);

begin

  if BufLen>1 shl 22 then

    fBufLen := 1 shl 22 else // 4 MB sounds right enough

  if BufLen<32 then

    fBufLen := 32;

    fBufLen := BufLen;

  fStream := aStream;

  SetLength(fBuf,fBufLen);

end;



constructor TFileBufferWriter.Create(aClass: TStreamClass; BufLen: integer);

begin

  Create(aClass.Create,BufLen);

  fInternalStream := true;

end;



destructor TFileBufferWriter.Destroy;

begin

  if fInternalStream then

    fStream.Free;

  inherited;

end;



function TFileBufferWriter.Flush: Int64;

begin

  if fPos>0 then begin

    fStream.Write(pointer(fBuf)^,fPos);

    fPos := 0;

  end;

  result := fTotalWritten;

  fTotalWritten := 0;

end;



procedure TFileBufferWriter.CancelAll;

begin

  fTotalWritten := 0;

  fPos := 0;

  fStream.Seek(0,soBeginning);

end;



procedure TFileBufferWriter.Write(Data: pointer; DataLen: integer);

begin

  if (DataLen<=0) or (Data=nil) then

    exit;

  inc(fTotalWritten,PtrUInt(DataLen));

  if fPos+DataLen>fBufLen then begin

    if fPos>0 then begin

      fStream.Write(pointer(fBuf)^,fPos);

      fPos := 0;

    end;

    if DataLen>fBufLen then begin

      fStream.Write(Data^,DataLen);

      exit;

    end;

  end;

  MoveFast(Data^,PByteArray(fBuf)^[fPos],DataLen);

  inc(fPos,DataLen);

end;



procedure TFileBufferWriter.WriteN(Data: Byte; Count: integer);

var len: integer;

begin

  inc(fTotalWritten,Count);

  while Count>0 do begin

    if Count>fBufLen then

      len := fBufLen else

      len := Count;

    if fPos+len>fBufLen then begin

      fStream.Write(pointer(fBuf)^,fPos);

      fPos := 0;

    end;

    FillcharFast(PByteArray(fBuf)^[fPos],len,Data);

    inc(fPos,len);

    dec(Count,len);

  end;

end;



procedure TFileBufferWriter.Write1(Data: byte);

begin

  if fPos+1>fBufLen then begin

    fStream.Write(pointer(fBuf)^,fPos);

    fPos := 0;

  end;

  PByteArray(fBuf)^[fPos] := Data;

  inc(fPos);

  inc(fTotalWritten);

end;



procedure TFileBufferWriter.Write4(Data: integer);

begin

  if fPos+sizeof(integer)>fBufLen then begin

    fStream.Write(pointer(fBuf)^,fPos);

    fPos := 0;

  end;

  PInteger(@PByteArray(fBuf)^[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+sizeof(Int64)>fBufLen then begin

    fStream.Write(pointer(fBuf)^,fPos);

    fPos := 0;

  end;

  PInt64(@PByteArray(fBuf)^[fPos])^ := Int64(Data8Bytes);

  inc(fPos,sizeof(Int64));

  inc(fTotalWritten,sizeof(Int64));

end;



procedure TFileBufferWriter.Write(const Text: RawByteString);

var L: integer;

begin

  L := length(Text);

  WriteVarUInt32(L);

  if L=0 then

    exit;

  Write(pointer(Text),L);

end;



procedure TFileBufferWriter.WriteShort(const Text: ShortString);

begin

  Write1(ord(Text[0]));

  Write(@Text[1],ord(Text[0]));

end;



procedure TFileBufferWriter.WriteBinary(const Data: RawByteString);

begin

  Write(pointer(Data),Length(Data));

end;



{$ifndef NOVARIANTS}

procedure TFileBufferWriter.Write(const Value: variant);

  procedure CustomType; // same code as VariantSave/VariantSaveLen

  begin

    Write(@TVarData(Value).VType,SizeOf(TVarData(Value).VType));

    Write(VariantSaveJSON(Value));

  end;

var tmp,buf: PAnsiChar;

    len: integer;

begin

  if TVarData(Value).VType>varAny then begin

    CustomType; // faster process without calling VariantSaveLength() for JSON

    exit;

  end;

  tmp := nil;

  len := VariantSaveLength(Value);

  if len=0 then

    raise ESynException.CreateUTF8('%.Write(VType=%) VariantSaveLength=0',

      [self,TVarData(Value).VType]);

  if fPos+len>fBufLen then begin

    fStream.Write(pointer(fBuf)^,fPos);

    fPos := 0;

    if len>fBufLen then begin

      GetMem(tmp,len);

      buf := tmp;

    end else

      buf := pointer(fBuf);

  end else

    buf := @PByteArray(fBuf)^[fPos];

  if VariantSave(Value,buf)=nil then

    raise ESynException.CreateUTF8('%.Write(VType=%) VariantSave=nil',

      [self,TVarData(Value).VType]);

  inc(fTotalWritten,len);

  if tmp=nil then

    inc(fPos,len) else begin

    fStream.Write(tmp^,len);

    FreeMem(tmp);

  end;

end;

{$endif}



procedure TFileBufferWriter.WriteXor(New,Old: PAnsiChar; Len: integer; crc: PCardinal);

var L: integer;

    Dest: PAnsiChar;

begin

  if (New=nil) or (Old=nil) then

    exit;

  inc(fTotalWritten,Len);

  while Len>0 do begin

    Dest := pointer(fBuf);

    if fPos+Len>fBufLen then begin

      fStream.Write(pointer(fBuf)^,fPos);

      fPos := 0;

    end else

      inc(Dest,fPos);

    if Len>fBufLen then

      L := fBufLen else

      L := Len;

    XorMemory(pointer(Dest),pointer(New),pointer(Old),L);

    if crc<>nil then

      crc^ := crc32c(crc^,Dest,L);

    inc(Old,L);

    inc(New,L);

    dec(Len,L);

    inc(fPos,L);

  end;

end;



procedure TFileBufferWriter.WriteRawUTF8DynArray(const Values: TRawUTF8DynArray;

  ValuesCount: integer);

var PI: PPtrUIntArray;

    n, i, fixedsize: integer;

    len: PtrUInt;

    P, PEnd: PByte;

    PBeg: PAnsiChar;

begin

  WriteVarUInt32(ValuesCount);

  PI := pointer(Values);

  if ValuesCount=0 then

    exit;

  fixedsize := length(Values[0]);

  if fixedsize>0 then

    for i := 1 to ValuesCount-1 do

      if (PI^[i]=0) or

         ({$ifdef FPC}PStrRec(Pointer(PI^[i]-STRRECSIZE))^.length

          {$else}PInteger(PI^[i]-sizeof(integer))^{$endif}<>fixedsize) then begin

        fixedsize := 0;

        break;

      end;

  WriteVarUInt32(fixedsize);

  repeat

    P := @PByteArray(fBuf)^[fPos];

    PEnd := @PByteArray(fBuf)^[fBufLen-8];

    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 PI^[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 := {$ifdef FPC}PStrRec(Pointer(PI^[i]-STRRECSIZE))^.length

                 {$else}PInteger(PI^[i]-sizeof(integer))^{$endif};

          if PtrUInt(PEnd)-PtrUInt(P)<=len then begin

            n := i;

            break; // avoid buffer overflow

          end;

          P := ToVarUInt32(len,P);

          MoveFast(pointer(PI^[i])^,P^,len);

          inc(P,len);

        end else

      // fixed size strings case

      for i := 0 to ValuesCount-1 do begin

        if PtrInt(PEnd)-PtrInt(P)<=fixedsize then begin

          n := i;

          break; // avoid buffer overflow

        end;

        MoveFast(pointer(PI^[i])^,P^,fixedsize);

        inc(P,fixedsize);

      end;

      len := PAnsiChar(P)-PBeg; // format: Isize+varUInt32s*strings

      PInteger(PBeg)^ := len-4;

      inc(fTotalWritten,len);

      inc(fPos,len);

      inc(PtrUInt(PI),n*sizeof(PtrInt));

      dec(ValuesCount,n);

      if ValuesCount=0 then

        break;

    end;

    fStream.Write(pointer(fBuf)^,fPos);

    fPos := 0;

  until false;

end;



procedure TFileBufferWriter.WriteRawUTF8List(List: TRawUTF8List;

  StoreObjectsAsVarUInt32: Boolean);

var i: integer;

begin

  if List=nil then

    WriteVarUInt32(0) else begin

    WriteRawUTF8DynArray(List.fList,List.Count);

    if List.fObjects=nil then

      StoreObjectsAsVarUInt32 := false; // no Objects[] values

    Write(@StoreObjectsAsVarUInt32,1);

    if StoreObjectsAsVarUInt32 then

      for i := 0 to List.fCount-1 do

        WriteVarUInt32(PtrUInt(List.fObjects[i]));

  end;

end;



procedure TFileBufferWriter.WriteStream(aStream: TCustomMemoryStream;

  aStreamSize: Integer);

begin

  if aStreamSize<0 then

    if aStream=nil then

      aStreamSize := 0 else

      aStreamSize := aStream.Size;

  WriteVarUInt32(aStreamSize);

  if aStreamSize>0 then

    Write(aStream.Memory,aStreamSize);

end;



procedure TFileBufferWriter.WriteVarInt32(Value: PtrInt);

begin

  if Value<=0 then

    // 0->0, -1->2, -2->4..

    Value := (-Value) shl 1 else

    // 1->1, 2->3..

    Value := (Value shl 1)-1;

  WriteVarUInt32(Value);

end;



procedure TFileBufferWriter.WriteVarUInt32(Value: PtrUInt);

var pos: integer;

begin

  if fPos+16>fBufLen then begin

    fStream.Write(pointer(fBuf)^,fPos);

    fPos := 0;

  end;

  pos := fPos;

  fPos := PtrUInt(ToVarUInt32(Value,@PByteArray(fBuf)^[fPos]))-PtrUInt(fBuf);

  inc(fTotalWritten,PtrUInt(fPos-Pos));

end;



procedure TFileBufferWriter.WriteVarInt64(Value: Int64);

var pos: integer;

begin

  if fPos+16>fBufLen then begin

    fStream.Write(pointer(fBuf)^,fPos);

    fPos := 0;

  end;

  pos := fPos;

  fPos := PtrUInt(ToVarInt64(Value,@PByteArray(fBuf)^[fPos]))-PtrUInt(fBuf);

  inc(fTotalWritten,PtrUInt(fPos-Pos));

end;



procedure TFileBufferWriter.WriteVarUInt64(Value: QWord);

var pos: integer;

begin

  if fPos+16>fBufLen then begin

    fStream.Write(pointer(fBuf)^,fPos);

    fPos := 0;

  end;

  pos := fPos;

  fPos := PtrUInt(ToVarUInt64(Value,@PByteArray(fBuf)^[fPos]))-PtrUInt(fBuf);

  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 (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 TFileBufferWriter.WriteVarUInt32Array(const Values: TIntegerDynArray;

  ValuesCount: integer; DataLayout: TFileBufferWriterKind);

var n, i, pos, diff: integer;

    P: PByte;

    PI: PIntegerArray;

    PBeg, PEnd: PAnsiChar;

begin

  WriteVarUInt32(ValuesCount);

  if ValuesCount=0 then

    exit;

  PI := pointer(Values);

  PByteArray(fBuf)^[fPos] := ord(DataLayout);

  inc(fPos);

  inc(fTotalWritten);

  if DataLayout in [wkOffsetU, wkOffsetI] then begin

    pos := fPos;

    fPos := PtrUInt(ToVarUInt32(PI^[0],@PByteArray(fBuf)^[fPos]))-PtrUInt(fBuf);

    diff := PI^[1]-PI^[0];

    inc(PtrUInt(PI),4);

    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 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,@PByteArray(fBuf)^[fPos]))-PtrUInt(fBuf);

    inc(fTotalWritten,PtrUInt(fPos-pos));

    if diff<>0 then

      exit; // same offset for all items (fixed sized records) -> quit now

  end;

  repeat

    P := @PByteArray(fBuf)^[fPos];

    PEnd := @PByteArray(fBuf)^[fBufLen-32];

    if PtrUInt(P)<PtrUInt(PEnd) then begin

      pos := fPos;

      case DataLayout of

      wkUInt32: begin

        n := (fBufLen-fPos)shr 2;

        if ValuesCount<n then

          n := ValuesCount;

        MoveFast(PI^,P^,n*4);

        inc(P,n*4);

      end;

      wkVarInt32, wkVarUInt32, wkOffsetU, wkOffsetI: begin

        PBeg := PAnsiChar(P); // leave space for chunk size

        inc(P,4);

        n := ValuesCount;

        case DataLayout of

        wkVarInt32:

          for i := 0 to ValuesCount-1 do begin

            P := ToVarInt32(PI^[i],P);

            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(PI^[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(PI^[i]-PI^[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(PI^[i]-PI^[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(PI),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(PtrUInt(PI),n*4);

      fPos := PtrUInt(P)-PtrUInt(fBuf);

      inc(fTotalWritten,PtrUInt(fPos-pos));

      dec(ValuesCount,n);

      if ValuesCount=0 then

        break;

    end;

    fStream.Write(pointer(fBuf)^,fPos);

    fPos := 0;

  until false;

end;



procedure TFileBufferWriter.WriteVarUInt64DynArray(

  const Values: TInt64DynArray; ValuesCount: integer; Offset: Boolean);

var n, i, pos: integer;

    diff: Int64;

    P, PEnd: PByte;

    PI: PInt64Array;

    PBeg: PAnsiChar;

begin

  WriteVarUInt32(ValuesCount);

  if ValuesCount=0 then

    exit;

  PI := pointer(Values);

  pos := fPos;

  if Offset then begin

    PByteArray(fBuf)^[fPos] := 1;

    fPos := PtrUInt(ToVarUInt64(PI^[0],@PByteArray(fBuf)^[fPos+1]))-PtrUInt(fBuf);

    diff := PI^[1]-PI^[0];

    inc(PtrUInt(PI),8);

    dec(ValuesCount);

    if ValuesCount=0 then begin

      inc(fTotalWritten,PtrUInt(fPos-pos));

      exit;

    end;

    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,@PByteArray(fBuf)^[fPos]))-PtrUInt(fBuf);

    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

    PByteArray(fBuf)^[fPos] := 0;

    inc(fPos);

  end;

  inc(fTotalWritten,PtrUInt(fPos-Pos));

  repeat

    P := @PByteArray(fBuf)^[fPos];

    PEnd := @PByteArray(fBuf)^[fBufLen-32];

    if PtrUInt(P)<PtrUInt(PEnd) then begin

      pos := fPos;

      PBeg := PAnsiChar(P); // leave space for chunk size

      inc(P,4);

      n := ValuesCount;

      if Offset then

        for i := 0 to ValuesCount-1 do begin

          P := ToVarUInt32(PI^[i]-PI^[i-1],P); // store diffs

          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(PtrUInt(PI),n*8);

      fPos := PtrUInt(P)-PtrUInt(fBuf);

      inc(fTotalWritten,PtrUInt(fPos-Pos));

      dec(ValuesCount,n);

      if ValuesCount=0 then

        break;

    end;

    fStream.Write(pointer(fBuf)^,fPos);

    fPos := 0;

  until false;

end;



function TFileBufferWriter.WriteDirectStart(maxSize: integer;

  const TooBigMessage: RawUTF8): PByte;

begin

  inc(maxSize,fPos);

  if maxSize>fBufLen then begin

    fTotalWritten := Flush;

    if maxSize>fBufLen then begin

      if maxSize>100 shl 20 then

        raise ESynException.CreateUTF8('%.WriteDirectStart: too big % - '+

          'we allow up to 100 MB block',[self,TooBigMessage]);

      fBufLen := maxSize+1024;

      SetString(fBuf,nil,fBufLen);

    end;

  end;

  result := @PByteArray(fBuf)^[fPos];

end;



procedure TFileBufferWriter.WriteDirectEnd(realSize: integer);

begin

  if fPos+realSize>fBufLen then

    raise ESynException.CreateUTF8(

      '%.WriteDirectEnd: too big %',[self,realSize]);

  inc(fPos,realSize);

  inc(fTotalWritten,realSize);

end;





{ TFileBufferReader }



procedure TFileBufferReader.Close;

begin

  fMap.UnMap;

end;



procedure TFileBufferReader.ErrorInvalidContent;

begin

  raise ESynException.Create('TFileBufferReader: invalid content');

end;



procedure TFileBufferReader.OpenFrom(aBuffer: pointer; aBufferSize: cardinal);

begin

  fCurrentPos := 0;

  fMap.Map(aBuffer,aBufferSize);

end;



function TFileBufferReader.OpenFrom(Stream: TStream): boolean;

begin

  result := false;

  if Stream=nil then

    exit;

  if Stream.InheritsFrom(TFileStream) then

    Open(TFileStream(Stream).Handle) else

  if Stream.InheritsFrom(TCustomMemoryStream) then

    with TCustomMemoryStream(Stream) do

      OpenFrom(Memory,Size) else

      exit;

  result := true

end;



procedure TFileBufferReader.Open(aFile: THandle);

begin

  fCurrentPos := 0;

  fMap.Map(aFile)

  // if Windows failed to find a contiguous VA space -> fall back on direct read

end;



function TFileBufferReader.Read(Data: pointer; DataLen: integer): integer;

var len: integer;

begin

  if DataLen>0 then

    if fMap.fBuf<>nil then begin

      // file up to 2 GB: use fast memory map

      len := fMap.fBufSize-fCurrentPos;

      if len>DataLen then

        len := DataLen;

      if Data<>nil then

        MoveFast(fMap.fBuf[fCurrentPos],Data^,len);

      inc(fCurrentPos,len);

      result := len;

    end else

      // file bigger than 2 GB: slower but accurate reading from file

      if Data=nil then begin

        FileSeek(fMap.fFile,soFromCurrent,DataLen);

        result := DataLen;

      end else

        result := FileRead(fMap.fFile,Data^,DataLen) else

      // DataLen=0

      result := 0;

end;



function TFileBufferReader.Read(out Text: RawByteString): integer;

begin

  result := ReadVarUInt32;

  if result=0 then

    exit;

  SetLength(Text,result);

  if Read(pointer(Text),result)<>result then

    ErrorInvalidContent;

end;



function TFileBufferReader.Read(out Text: RawUTF8): integer;

begin

  result := ReadVarUInt32;

  if result=0 then

    exit;

  SetLength(Text,result);

  if Read(pointer(Text),result)<>result then

    ErrorInvalidContent;

end;



function TFileBufferReader.ReadRawUTF8: RawUTF8;

begin

  Read(result);

end;



procedure TFileBufferReader.ReadChunk(var 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: pointer;

begin

  if (fMap.fBuf=nil) or (fCurrentPos>=fMap.fBufSize) then

    result := nil else

    result := @fMap.fBuf[fCurrentPos];

end;



function TFileBufferReader.CurrentPosition: integer;

begin

  if (fMap.fBuf=nil) or (fCurrentPos>=fMap.fBufSize) then

    result := -1 else

    result := fCurrentPos;

end;



function TFileBufferReader.ReadPointer(DataLen: PtrUInt;

  var aTempData: RawByteString): pointer;

begin

  if fMap.fBuf=nil then begin

    // read from file

    if DataLen>PtrUInt(Length(aTempData)) then begin

      aTempData := ''; // so no move() call in SetLength() below

      SetLength(aTempData,DataLen);

    end;

    if PtrUInt(FileRead(fMap.fFile,pointer(aTempData)^,DataLen))<>DataLen then

      result := nil else // invalid content

      result := pointer(aTempData);

  end else

  if DataLen+fCurrentPos>fMap.fBufSize then

    // invalid request

    result := nil else begin

    // get pointer to data from current memory map (no data copy)

    result := @fMap.fBuf[fCurrentPos];

    inc(fCurrentPos,DataLen);

  end;

end;



function TFileBufferReader.ReadStream(DataLen: PtrInt): TCustomMemoryStream;

var FileCurrentPos: Int64;

begin

  if DataLen<0 then

    DataLen := ReadVarUInt32;

  if DataLen<>0 then

    if fMap.fBuf=nil then begin

      FileCurrentPos := FileSeek64(fMap.fFile,0,soFromCurrent);

      if FileCurrentPos+DataLen>fMap.fFileSize then

        // invalid content

        result := nil else begin

        // create a temporary memory map buffer stream

        result := TSynMemoryStreamMapped.Create(fMap.fFile,DataLen,FileCurrentPos);

        FileSeek64(fMap.fFile,DataLen,soFromCurrent);

      end;

    end else

    if PtrUInt(DataLen)+fCurrentPos>fMap.fBufSize then

      // invalid content

      result := nil else begin

      // get pointer to data from current memory map (no data copy)

      result := TSynMemoryStream.Create(@fMap.fBuf[fCurrentPos],DataLen);

      inc(fCurrentPos,DataLen);

    end else

    // DataLen=0 -> invalid content

    result := nil;

end;



function TFileBufferReader.ReadByte: PtrUInt;

begin

  if fMap.fBuf<>nil then

    if fCurrentPos>=fMap.fBufSize then

      // invalid request

      result := 0 else begin

      // read one byte from current memory map

      result := ord(fMap.fBuf[fCurrentPos]);

      inc(fCurrentPos);

    end else begin

    // read from file if >= 2 GB (slow, but works)

    result := 0;

    if FileRead(fMap.fFile,result,1)<>1 then

      result := 0;

  end;

end;



function TFileBufferReader.ReadCardinal: cardinal;

begin

  if fMap.fBuf<>nil then

    if fCurrentPos+3>=fMap.fBufSize then

      // invalid request

      result := 0 else begin

      // read one byte from current memory map

      result := PCardinal(fMap.fBuf+fCurrentPos)^;

      inc(fCurrentPos,4);

    end else begin

      // read from file if >= 2 GB (slow, but works)

      result := 0;

      if FileRead(fMap.fFile,result,4)<>4 then

        result := 0;

    end;

end;



function TFileBufferReader.ReadVarUInt32: PtrUInt;

var c, n: PtrUInt;

begin

  result := ReadByte;

  if result>$7f then begin

    n := 0;

    result := result and $7F;

    repeat

      c := ReadByte;

      inc(n,7);

      if c<=$7f then break;

      result := result or ((c and $7f) shl n);

    until false;

    result := result or (c shl n);

  end;

end;



function TFileBufferReader.ReadVarInt32: PtrInt;

begin

  result := ReadVarUInt32;

  if result and 1<>0 then

    // 1->1, 3->2..

    result := result shr 1+1 else

    // 0->0, 2->-1, 4->-2..

    result := -(result shr 1);

end;



function TFileBufferReader.ReadVarUInt64: QWord;

var c, n: PtrUInt;

begin

  result := ReadByte;

  if result>$7f then begin

    n := 0;

    result := result and $7F;

    repeat

      c := ReadByte;

      inc(n,7);

      if c<=$7f then break;

      result := result or (QWord(c and $7f) shl n);

    until false;

    result := result or (QWord(c) shl n);

  end;

end;



function TFileBufferReader.ReadVarInt64: Int64;

begin

  result := ReadVarUInt64;

  if result 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)<PtrUInt(pEnd) 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(pEnd) 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(pEnd) 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(pEnd) 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(pEnd) then continue else break;

      end;

    end; // case p^ of

  until false;

  result := (PtrUInt(V)-result) shr 2; // returns count of stored integer

end;



function TFileBufferReader.ReadVarUInt32Array(var Values: TIntegerDynArray): PtrInt;

var count, n, i, diff: integer;

    DataLayout: TFileBufferWriterKind;

    P, PEnd: PByte;

    PI: PInteger;

    PIA: PIntegerArray absolute PI;

    BufTemp: RawByteString;

begin

  result := ReadVarUInt32;

  if result=0 then

    exit;

  DataLayout := TFileBufferWriterKind(ReadByte);

  if DataLayout=wkFakeMarker then begin

    result := -result;

    exit;

  end;

  count := result;

  if count>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)<PtrUInt(PEnd)) do begin

          PI^ := FromVarInt32(P);

          dec(count);

          inc(PI);

        end;

      wkVarUInt32:

        while (count>0) and (PtrUInt(P)<PtrUInt(PEnd)) do begin

          PI^ := FromVarUInt32(P);

          dec(count);

          inc(PI);

        end;

      wkSorted: begin

        n := CleverReadInteger(pointer(P),pointer(PEnd),PI);

        dec(count,n);

        inc(PtrUInt(PI),n*4);

      end;

      wkOffsetU: begin

        while (count>0) and (PtrUInt(P)<PtrUInt(PEnd)) do begin

          PIA^[1] := PIA^[0]+integer(FromVarUInt32(P));

          dec(count);

          inc(PI);

        end;

        if count<=0 then

          inc(PI); // make sure PI=@Values[result]

      end;

      wkOffsetI: begin

        while (count>0) and (PtrUInt(P)<PtrUInt(PEnd)) do begin

          PIA^[1] := PIA^[0]+FromVarInt32(P);

          dec(count);

          inc(PI);

        end;

        if count<=0 then

          inc(PI); // make sure PI=@Values[result]

      end;

      else

        ErrorInvalidContent;

      end;

    until count<=0;

    if PI<>@Values[result] then

      ErrorInvalidContent;

  end;

end;



function TFileBufferReader.ReadVarUInt64Array(var Values: TInt64DynArray): PtrInt;

var count, diff, i: integer;

    Offset: boolean;

    P, PEnd: PByte;

    PI: PInt64;

    PIA: PInt64Array absolute PI;

    BufTemp: RawByteString;

begin

  result := ReadVarUInt32;

  if result=0 then

    exit;

  count := result;

  if count>length(Values) then // only set length is not big enough

    SetLength(Values,count);

  Offset := boolean(ReadByte);

  PI := pointer(Values);

  if Offset then begin

    PI^ := ReadVarUInt64; // read first value

    dec(count);

    diff := ReadVarUInt32;

    if diff=0 then begin

      // read all offsets, and compute (not fixed sized records)

      repeat

        ReadChunk(P,PEnd,BufTemp); // raise ErrorInvalidContent on error

        while (count>0) and (PtrUInt(P)<PtrUInt(PEnd)) do begin

          PIA^[1] := PIA^[0]+integer(FromVarUInt32(P));

          dec(count);

          inc(PI);

        end;

      until count<=0;

      {$ifopt C+} inc(PI); {$endif} // to make assert() below work

    end else begin

      // same offset for all items (fixed sized records)

      for i := 0 to count-1 do

        PIA^[i+1] := PIA^[i]+diff;

      {$ifopt C+} inc(PI,count+1); count := 0; {$endif} // for assert() below

    end;

  end else

  repeat

    ReadChunk(P,PEnd,BufTemp); // raise ErrorInvalidContent on error

    while (count>0) and (PtrUInt(P)<PtrUInt(PEnd)) do begin

      PI^ := FromVarUInt64(P);

      dec(count);

      inc(PI);

    end;

  until count<=0;

  assert((count=0)and(PI=@Values[result]));

end;



function TFileBufferReader.ReadRawUTF8List(List: TRawUTF8List): boolean;

var i: integer;

    StoreObjectsAsVarUInt32: Boolean;

begin

  if (fMap.fBuf<>nil) and (List<>nil) then

  with List do begin

    BeginUpdate;

    try

      Capacity := 0; // finalize both fObjects[] and fList[]

      fCount := ReadVarRawUTF8DynArray(List.fList);

      result := true;

      if fCount=0 then

        exit;

      Read(@StoreObjectsAsVarUInt32,1);

      if StoreObjectsAsVarUInt32 then begin

        fObjectsOwned := false; // Int32 here, not instances

        SetLength(fObjects,Capacity);

        for i := 0 to fCount-1 do

          fObjects[i] := TObject(ReadVarUInt32);

      end;

    finally

      EndUpdate;

    end;

  end else

    result := false;

end;



function TFileBufferReader.ReadVarRawUTF8DynArray(var Values: TRawUTF8DynArray): PtrInt;

var count, len, fixedsize: integer;

    P, PEnd: PByte;

    PI: PRawUTF8;

    BufTemp: RawByteString;

begin

  result := ReadVarUInt32;

  if result=0 then

    exit;

  count := result;

  if count>length(Values) then // only set length is not big enough

    SetLength(Values,count);

  PI := pointer(Values);

  fixedsize := ReadVarUInt32;

  repeat

    ReadChunk(P,PEnd,BufTemp); // raise ErrorInvalidContent on error

    if fixedsize=0 then

    while (count>0) and (PtrUInt(P)<PtrUInt(PEnd)) do begin

      len := FromVarUInt32(P);

      if len>0 then begin

        SetString(PI^,PAnsiChar(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)<PtrUInt(PEnd)) do begin

      SetString(PI^,PAnsiChar(P),fixedsize);

      inc(P,fixedsize);

      dec(count);

      inc(PI);

    end;

  until count<=0;

  if PI<>@Values[result] then

    ErrorInvalidContent;

end;



{$ifndef CPU64}

function TFileBufferReader.Seek(Offset: Int64): boolean;

begin

  if (Offset<0) or (Offset>fMap.fFileSize) then

    result := False else

  if fMap.fBuf=nil then

    result := FileSeek64(fMap.fFile,Offset,soFromBeginning)=Offset else begin

    fCurrentPos := Int64Rec(Offset).Lo;

    result := true;

  end;

end;

{$endif CPU64}



function TFileBufferReader.Seek(Offset: PtrInt): boolean;

begin

  // we don't need to handle fMap=0 here

  if fMap.fBuf=nil then

    Result := FileSeek(fMap.fFile,Offset,0)=Offset else

  if (fMap.fBuf<>nil) and (PtrUInt(Offset)<PPtrUInt(@fMap.fFileSize)^) then begin

    fCurrentPos := Offset;

    result := true;

  end else

    result := false;

end;





{ TSynTable }





{$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 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 SortDouble(P1,P2: PUTF8Char): PtrInt;

var V: Double;

begin

  if P1<>P2 then

    if P1<>nil then

      if P2<>nil then begin

        V := PDouble(P1)^-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;



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;



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 PropNameValid(P: PUTF8Char): boolean;

begin

  result := false;

  if (P=nil) or not (P^ in ['a'..'z','A'..'Z','_']) then

    exit; // first char must be alphabetical

  inc(P);

  while P^<>#0 do

    if not (ord(P^) in IsIdentifier) then

      exit else // following chars can be alphanumerical

      inc(P);

  result := true;

end;



function JsonPropNameValid(P: PUTF8Char): boolean;

{$ifdef HASINLINE}

begin

  if (P<>nil) and (ord(P^) in IsJsonIdentifierFirstChar) then begin

    repeat

      inc(P);

    until not(ord(P^) in IsJsonIdentifier);

    if P^=#0 then begin

      result := true;

      exit;

    end else begin

      result := false;

      exit;

    end;

  end else

    result := false;

end;

{$else}

asm

    test eax,eax

    jz @z

    movzx edx,byte ptr [eax]

    bt [offset @f],edx

    mov ecx,offset @c

    jb @2

@z: xor eax,eax

    ret

@f: dd 0,$03FF0010,$87FFFFFE,$07FFFFFE,0,0,0,0 // IsJsonIdentifierFirstChar

@c: dd 0,$03FF4000,$AFFFFFFE,$07FFFFFE,0,0,0,0 // IsJsonIdentifier

@s: mov dl,[eax]

    bt [ecx],edx

    jnb @1

@2: mov dl,[eax+1]

    bt [ecx],edx

    jnb @1

    mov dl,[eax+2]

    bt [ecx],edx

    jnb @1

    mov dl,[eax+3]

    bt [ecx],edx

    lea eax,[eax+4]

    jb @s

@1: test dl,dl

    setz al

end;

{$endif}



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<fField.Count do

          with TSynTableFieldProperties(fField.List[result.FieldNumber]) do

          if (Offset<0) or not (tfoIndex in Options) then

            break else

            Inc(result.FieldNumber);

      end else

      // not indexed field: insert after previous fixed-sized fields

      if fFieldVariableIndex>=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.FieldNumber<fField.Count do

        with TSynTableFieldProperties(fField.List[result.FieldNumber]) do

        if not (tfoIndex in Options) then

          break else

          Inc(result.FieldNumber);

      fField.Insert(result.FieldNumber,result);

    end else

      // not indexed field: just add at the end of the field list

      result.FieldNumber := fField.Add(result);

  end;

  if tfoUnique in aOptions then begin

    fFieldHasUniqueIndexes := true;

    result.AddFilterOrValidate(TSynValidateTableUniqueField.Create);

  end;

  AfterFieldModif; // set Offset,FieldNumber,FieldSize fFieldVariableIndex/Offset

end;



procedure TSynTable.UpdateFieldData(RecordBuffer: PUTF8Char; RecordBufferLen,

  FieldIndex: integer; var result: TSBFString; const NewFieldData: TSBFString='');

var NewSize, DestOffset, OldSize: integer;

    F: TSynTableFieldProperties;

    NewData, Dest: PAnsiChar;

begin

  if (self<>nil) 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);

  SetLength(Result,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;

var i: integer;

begin

  if self<>nil then

    for i := 0 to fField.Count-1 do begin

      result := TSynTableFieldProperties(fField.List[i]);

      if IdemPropNameU(result.Name,aName) then

        exit;

    end;

  result := nil;

end;



function TSynTable.GetFieldIndexFromName(const aName: RawUTF8): integer;

begin

  if self<>nil then

    for result := 0 to fField.Count-1 do

      if IdemPropNameU(TSynTableFieldProperties(fField.List[result]).Name,aName) then

        exit;

  result := -1;

end;



function TSynTable.GetFieldIndexFromShortName(const aName: ShortString): integer;

begin

  if self<>nil then

    for result := 0 to fField.Count-1 do

      with TSynTableFieldProperties(fField.List[result]) do

      if IdemPropName(aName,pointer(Name),length(Name)) then

        exit;

  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 fIndex<cardinal(fField.Count) then begin

        F := TSynTableFieldProperties(fField.List[fIndex]);

        if F.SortCompare(GetData(Data,F),pointer(Statement.Where[0].ValueSBF))<>0 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(PtrUInt(result),PByte(result)^+1) else begin

          PB := result;

          inc(PtrUInt(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(PtrUInt(result));

        inc(PtrUInt(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

  Int64(fFieldIsVarString) := 0;

  Int64(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

  if SynTableVariantType=nil then

    SynTableVariantType := SynRegisterCustomVariantType(TSynTableVariantType);

  if data.VType and VTYPE_STATIC<>0 then

    VarClear(result);

  data.VType := SynTableVariantType.VarType;

  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 := Count<length(IDs);

    if not result then

      exit;

    for F := 0 to fField.Count-1 do

    with TSynTableFieldProperties(fField.List[F]) do

    if F in AvailableFields then begin

      // add previous field content: will handle any field offset change in record

      aSize := Getlength(Data);

      WR.Write(Data,aSize);

      Inc(PtrUInt(Data),aSize);

    end else

      // add default field content for a newly added field

      WR.Write(Pointer(fDefaultFieldData),fDefaultFieldLength);

    if WR.fTotalWritten>1 shl 30 then

      raise ETableDataException.CreateUTF8('%: File size too big (>1GB)',[self]) else

      Offsets64[Count] := WR.fTotalWritten;

    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;



{$ifndef DELPHI5OROLDER} // Delphi 5 does not like this code, do not know why :(

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(PDouble(FieldBuffer)^);

  // some variable-size field value

  tftVarUInt32:

    W.Add(FromVarUInt32(PByte(FieldBuffer)));

  tftVarInt32:

    W.Add(FromVarInt32(PByte(FieldBuffer)));

  tftVarUInt64:

    W.Add(Int64(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;

{$endif}



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 UNICODE}

    WS: WideString;

    {$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 := 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 UNICODE}

      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 UNICODE}

      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}



function TSynTableFieldProperties.GetValue(FieldBuffer: pointer): RawUTF8;

var len: integer;

    PB: PByte absolute FieldBuffer;

    PC: PAnsiChar absolute FieldBuffer;

begin

  case FieldType of

  // fixed-sized field value

  tftBoolean:

    JSONBoolean(PBoolean(FieldBuffer)^,result);

  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:

    ExtendedToStr(PDouble(FieldBuffer)^,DOUBLE_PRECISION,result);

  // some variable-size field value

  tftVarUInt32:

    UInt32ToUtf8(FromVarUInt32(PB),result);

  tftVarInt32:

    Int32ToUtf8(FromVarInt32(PB),result);

  tftVarUInt64:

    Int64ToUtf8(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) else

      result := '';

  end;

  else

    result := ''; // tftBlobExternal fields e.g. must be directly accessed

  end;

end;



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<n then begin

    SetLength(OrderedIndexReverse,n); // resize if needed

    nrev := n;

  end;

  ndx := OrderedIndex[aOrderedIndex];

  if ndx>=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 (L<R) and Assigned(Owner.GetRecordData) then

  repeat

    I := L; J := R;

    P := (L + R) shr 1;

    repeat

      with Owner do begin

        SortPivot := GetData(GetRecordData(OrderedIndex[P],DataTemp1),self);

        while SortCompare(GetData(GetRecordData(OrderedIndex[I],DataTemp2),self),

          SortPivot)<0 do Inc(I);

        while SortCompare(GetData(GetRecordData(OrderedIndex[J],DataTemp2),self),

          SortPivot)>0 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 L < J then

      OrderedIndexSort(L, J);

    L := I;

  until I >= 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 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(aOldIndex<length(OrderedIndexReverse));

    //assert(IntegerScanIndex(Pointer(OrderedIndex),OrderedIndexCount,aOldIndex)=OrderedIndexReverse[aOldIndex]);

    aOldIndexIndex := OrderedIndexReverse[aOldIndex]; // use FAST reverse array

    if aOldIndexIndex<0 then

      exit; // invalid Old index

    if aNewIndex<0 then begin

      // deleted record

      DeleteInteger(OrderedIndex,OrderedIndexCount,aOldIndexIndex);

      Reverse(OrderedIndex,OrderedIndexCount,pointer(OrderedIndexReverse));

      // no need to refresh OrderedIndex[], since data will remain sorted

    end else begin

      // updated record

      OrderedIndex[aOldIndexIndex] := aNewIndex;

      OrderedIndexReverseSet(aOldIndexIndex);

      if (aOldRecordData<>nil) 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}PStrRec(Pointer(PtrUInt(Value)-STRRECSIZE))^.length

                {$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 := 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: TObjectList);

begin

  if List=nil then

    List := TObjectList.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)^;

      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;

      tftDouble: begin

        PDouble(@SortCompareTmp)^ := PDouble(P1)^-PDouble(P2)^;

        if PDouble(@SortCompareTmp)^<0 then

          goto minus else

        if 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;

      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;

      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 i<L do begin

            result := PtrInt(NormToUpperAnsi7[P1[i]])-PtrInt(NormToUpperAnsi7[P2[i]]);

            if result<>0 then

              exit else

              inc(i);

          end;

        end else begin

          i := 0;

          while i<L do begin

            result := PtrInt(P1[i])-PtrInt(P2[i]);

            if result<>0 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; overload;

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 V<Value then exit;

      soLessThanOrEqualTo:    if V<=Value then exit;

      soGreaterThan:          if V>Value 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; overload;

begin

  result := true;

  if SBF<>nil then

  repeat

    case Oper of

      soEqualTo:              if PDouble(SBF)^=Value then exit;

      soNotEqualTo:           if PDouble(SBF)^<>Value then exit;

      soLessThan:             if PDouble(SBF)^<Value then exit;

      soLessThanOrEqualTo:    if PDouble(SBF)^<=Value then exit;

      soGreaterThan:          if PDouble(SBF)^>Value then exit;

      soGreaterThanOrEqualTo: if 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 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 i<L then continue else break;

    end;

    exit;

  until false;

  result := Default;

end;



function StrCompIL(P1,P2: PUTF8Char; L, Default: Integer): PtrInt;

var i: PtrInt;

begin

  i := 0;

  repeat

    if NormToUpperAnsi7[P1[i]]=NormToUpperAnsi7[P2[i]] then begin

      inc(i);

      if i<L then continue else break;

    end;

    result := PtrInt(P1[i])-PtrInt(P2[i]);

    exit;

  until false;

  result := Default;

end;



{$ifdef FPC}

function BooleanNormalize(value: boolean): integer; inline;

begin

  if value then

    result := 1 else

    result := 0;

end;

{$endif}



var

  /// a temporary buffer, big enough for using the SoundEx algorithm

  SoundExtTmp: array[byte] of AnsiChar;



function CompareOperator(FieldType: TSynTableFieldType; SBF, SBFEnd: PUTF8Char;

  Value: PUTF8Char; ValueLen: integer; Oper: TCompareOperator;

  CaseSensitive: boolean): boolean; overload;

var L, Cmp: PtrInt;

    PB: PByte;

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(byte(SBF^) in IsWord) 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 (byte(SBF^) in IsWord) 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 SBF<SBFEnd then

          continue else break;

      end;

      soSoundsLikeEnglish,

      soSoundsLikeFrench,

      soSoundsLikeSpanish: begin

        if L>high(SoundExtTmp) then

          cmp := high(SoundExtTmp) else

          cmp := L;

        SoundExtTmp[cmp] := #0; // TSynSoundEx expect the buffer to be #0 terminated

        MoveFast(SBF^,SoundExtTmp,cmp);

        case FieldType of

        tftWinAnsi:

          if PSynSoundEx(Value)^.Ansi(SoundExtTmp) then

            exit;

        tftUTF8:

          if PSynSoundEx(Value)^.UTF8(SoundExtTmp) 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 }



function IsRowID(FieldName: PUTF8Char): boolean;

begin

  if FieldName=nil then

    result := false else

    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')));

end;



function IsRowID(FieldName: PUTF8Char; FieldLen: integer): boolean;

begin

  case FieldLen of

  2: result :=

    PWord(FieldName)^ and $dfdf=ord('I')+ord('D')shl 8;

  5: result :=

    (PInteger(FieldName)^ and $dfdfdfdf=

      ord('R')+ord('O')shl 8+ord('W')shl 16+ord('I')shl 24) and

    (ord(FieldName[4]) and $df=ord('D'));

  else result := false;

  end;

end;



function IsRowIDShort(const FieldName: shortstring): boolean;

begin

  result :=

    (PInteger(@FieldName)^ and $DFDFFF=

      2+ord('I')shl 8+ord('D')shl 16) or

    ((PIntegerArray(@FieldName)^[0] and $dfdfdfff=

      5+ord('R')shl 8+ord('O')shl 16+ord('W')shl 24) and

     (PIntegerArray(@FieldName)^[1] and $dfdf=

       ord('I')+ord('D')shl 8));

end;



function GetNextFieldProp(var P: PUTF8Char; var Prop: RawUTF8): boolean;

var B: PUTF8Char;

begin

  while P^ in [#1..' ',';'] do inc(P);

  B := P;

  while ord(P^) in IsIdentifier do inc(P); // go to end of field name

  SetRawUTF8(Prop,B,P-B);

  while P^ in [#1..' ',';'] do inc(P);

  result := Prop<>'';

end;





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;

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;

  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'; // not void

    {$ifndef NOVARIANTS}

    SetVariantNull(Where.ValueVariant);

    {$endif}

  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,n+n shr 3+8);

      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;

begin

  result := false;

  Where.ParenthesisBefore := whereBefore;

  Where.JoinedOR := whereWithOR;

  Where.NotClause := whereNotClause;

  Where.Field := FieldIndex; // 0 = ID, otherwise PropertyIndex+1

  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';

        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 - without :(...): by now

       inc(P);

       while P^<>')' do

         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);

    SetLength(fSelect,GetBitsCount(SimpleFieldsBits,MAX_SQLFIELDS)+1);

    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);

      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<>'' 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);

var i: integer;

begin

  FillcharFast(Fields,sizeof(Fields),0);

  withID := false;

  for i := 0 to Length(Select)-1 do

    if Select[i].Field=0 then

      withID := true else

      include(Fields,Select[i].Field-1);

end;





{$ifndef DELPHI5OROLDER}



{ TSynTableData }



procedure TSynTableData.CheckVTableInitialized;

begin

  if VTable=nil then

    raise ETableDataException.Create('TSynTableData non initialized');

end;



{$ifndef NOVARIANTS}



function TSynTableData.GetFieldValue(const FieldName: RawUTF8): Variant;

begin

  GetFieldVariant(FieldName,result);

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

  VTable := aTable;

  VID := aID;

  VValue := VTable.DefaultRecordData;

  {$ifdef UNICODE}FillcharFast(Filler,sizeof(Filler),0);{$endif}

end;



procedure TSynTableData.Init(aTable: TSynTable; aID: Integer;

  RecordBuffer: pointer; RecordBufferLen: integer);

begin

  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.SetFieldValue(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}





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

  inc(P,Len);

  with PSynLZTrailer(P-sizeof(TSynLZTrailer))^ do

    if (Magic=aMagic) and (HeaderRelativeOffset<Len) and

       (PSynLZHead(P-HeaderRelativeOffset)^.Magic=aMagic) then

      // trim existing content

      result := Len-HeaderRelativeOffset else

      result := Len;

end;



function CompressSynLZ(var DataRawByteString; Compress: boolean): AnsiString;

var DataLen, len: integer;

    P: PAnsiChar;

    Data: RawByteString absolute DataRawByteString;

begin

  DataLen := length(Data);

  if DataLen<>0 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.Write(Head,sizeof(Head));

    Dest.Write(D^,Head.CompressedSize);

    Trailer.HeaderRelativeOffset := result+(sizeof(Head)+sizeof(Trailer));

    Trailer.Magic := Magic;

    Dest.Write(Trailer,sizeof(Trailer));

    result := Head.CompressedSize+(sizeof(Head)+sizeof(Trailer));

  finally

    tmp.Done;

  end;

end;



function StreamSynLZ(Source: TCustomMemoryStream; const DestFile: TFileName;

  Magic: cardinal): integer;

var F: TFileStream;

begin

  F := TFileStream.Create(DestFile,fmCreate);

  try

    result := StreamSynLZ(Source,F,Magic);

  finally

    F.Free;

  end;

end;



const

  /// 128 MB default buffer

  FILESYNLZ_BLOCKSIZE = 128*1024*1024;



function FileSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean;

var src,dst: RawByteString;

    S,D: TFileStream;

    Head: TSynLZHead;

    Count: Int64;

begin

  result := false;

  if FileExists(Source) then

  try

    S := FileStreamSequentialRead(Source);

    try

      DeleteFile(Dest);

      D := TFileStream.Create(Dest,fmCreate);

      try

        Head.Magic := Magic;

        Count := S.Size;

        while Count>0 do begin

          if Count>FILESYNLZ_BLOCKSIZE then

            Head.UnCompressedSize := FILESYNLZ_BLOCKSIZE else

            Head.UnCompressedSize := Count;

          if src='' then

            SetString(src,nil,Head.UnCompressedSize);

          if dst='' then

            SetString(dst,nil,SynLZcompressdestlen(Head.UnCompressedSize));

          S.Read(pointer(src)^,Head.UnCompressedSize);

          Head.HashUncompressed := Hash32(pointer(src),Head.UnCompressedSize);

          Head.CompressedSize :=

            SynLZcompress1(pointer(src),Head.UnCompressedSize,pointer(dst));

          Head.HashCompressed := Hash32(pointer(dst),Head.CompressedSize);

          if (D.Write(Head,sizeof(Head))<>sizeof(Head)) or

             (D.Write(pointer(dst)^,Head.CompressedSize)<>Head.CompressedSize) then

            exit;

          dec(Count,Head.UnCompressedSize);

        end;

      finally

        D.Free;

      end;

      result := FileSetDateFrom(Dest,S.Handle);

    finally

      S.Free;

    end;

  except

    on Exception do

      result := false;

  end;

end;



function FileUnSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean;

var src,dst: RawByteString;

    S,D: TFileStream;

    Count: Int64;

    Head: TSynLZHead;

begin

  result := false;

  if FileExists(Source) then

  try

    S := FileStreamSequentialRead(Source);

    try

      DeleteFile(Dest);

      D := TFileStream.Create(Dest,fmCreate);

      try

        Count := S.Size;

        while Count>0 do begin

          if S.Read(Head,sizeof(Head))<>Sizeof(Head) then

            exit;

          dec(Count,sizeof(Head));

          if (Head.Magic<>Magic) or

             (Head.CompressedSize>Count) then

            exit;

          if Head.CompressedSize>length(src) then

            SetString(src,nil,Head.CompressedSize);

          if S.Read(pointer(src)^,Head.CompressedSize)<>Head.CompressedSize then

            exit;

          dec(Count,Head.CompressedSize);

          if (Hash32(pointer(src),Head.CompressedSize)<>Head.HashCompressed) or

             (SynLZdecompressdestlen(pointer(src))<>Head.UnCompressedSize) then

            exit;

          if Head.UnCompressedSize>length(dst) then

            SetString(dst,nil,Head.UnCompressedSize);

          if (SynLZDecompress1(pointer(src),Head.CompressedSize,pointer(dst))<>Head.UnCompressedSize) or

             (Hash32(pointer(dst),Head.UnCompressedSize)<>Head.HashUncompressed) then

            exit;

          if D.Write(pointer(dst)^,Head.UncompressedSize)<>Head.UncompressedSize then

            exit;

        end;

      finally

        D.Free;

      end;

      result := FileSetDateFrom(Dest,S.Handle);

    finally

      S.Free;

    end;

  except

    on Exception do

      result := false;

  end;

end;



function FileIsZynLZ(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

          if Head.CompressedSize+SizeOf(Head)=S.Size then

            result := true;

    finally

      S.Free;

    end;

  except

    on Exception do

      result := false;

  end;

end;



function StreamUnSynLZ(const Source: TFileName; Magic: cardinal): TMemoryStream; overload;

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: PtrInt;

    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-sourcePosition<sizeof(head) then

    exit;

  resultSize := 0;

  repeat

    Source.Read(Head,sizeof(Head));

    if Head.Magic<>Magic then begin

      // Source not positioned as expected -> try from the end

      Source.Position := sourceSize-sizeof(Trailer);

      Source.Read(Trailer,sizeof(Trailer));

      if Trailer.Magic<>Magic then

        exit;

      sourcePosition := sourceSize-Trailer.HeaderRelativeOffset;

      Source.Position := sourcePosition;

      Source.Read(Head,sizeof(Head));

      if Head.Magic<>Magic then

        exit;

    end;

    inc(sourcePosition,sizeof(Head));

    if sourcePosition+Head.CompressedSize>sourceSize then

      exit;

    if Source.InheritsFrom(TCustomMemoryStream) then begin

      S := PAnsiChar(TCustomMemoryStream(Source).Memory)+PtrUInt(sourcePosition);

      Source.Seek(Head.CompressedSize,soFromCurrent);

    end else begin

      if Head.CompressedSize>length(Buf) then

        SetString(Buf,nil,Head.CompressedSize);

      S := pointer(Buf);

      Source.Read(S^,Head.CompressedSize);

    end;

    inc(sourcePosition,Head.CompressedSize);

    if (Source.Read(Trailer,sizeof(Trailer))<>sizeof(Trailer)) or

       (Trailer.Magic<>Magic) then

      // trailer not available in old .synlz layout, or in FileSynLZ multiblocks

      Source.Position := sourcePosition else

      sourceSize := 0; // should be monoblock

    // Source stream will now point after all data

    stored := (Head.CompressedSize=Head.UnCompressedSize) and

              (Head.HashCompressed=Head.HashUncompressed);

    if not stored then

      if SynLZdecompressdestlen(S)<>Head.UnCompressedSize then

        exit;

    if Hash32(S,Head.CompressedSize)<>Head.HashCompressed then

      exit;

    if result=nil then

      result := THeapMemoryStream.Create else begin

      {$ifndef CPU64}

      if Int64(resultSize)+Head.UnCompressedSize>maxInt then begin

        FreeAndNil(result); // result TMemoryStream should stay in memory!

        break;

      end;

      {$endif}

    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(D,Head.UnCompressedSize)<>Head.HashUncompressed then

      FreeAndNil(result);

  until (result=nil) or (sourcePosition>=sourceSize);

end;



const

  SYNLZCOMPRESS_STORED = #0;

  SYNLZCOMPRESS_SYNLZ = #1;



function SynLZCompress(const Data: RawByteString; CompressionSizeTrigger: integer): RawByteString;

begin

  SynLZCompress(pointer(Data),length(Data),result,CompressionSizeTrigger);

end;



procedure SynLZCompress(P: PAnsiChar; PLen: integer; out Result: RawByteString;

  CompressionSizeTrigger: integer);

var len: integer;

    R: PAnsiChar;

    crc: cardinal;

    tmp: array[0..4095] of AnsiChar;  // resize Result instead of TSynTempBuffer 

begin

  if PLen=0 then

    exit;

  crc := crc32c(0,P,PLen);

  if PLen<CompressionSizeTrigger then begin

    SetString(result,nil,PLen+9);

    R := pointer(result);

    PCardinal(R)^ := crc;

    R[4] := SYNLZCOMPRESS_STORED;

    PCardinal(R+5)^ := crc;

    MoveFast(P^,R[9],PLen);

  end else begin

    len := SynLZcompressdestlen(PLen)+9;

    if len>sizeof(tmp) then begin

      SetString(result,nil,len);

      R := pointer(result);

    end else

      R := @tmp;

    PCardinal(R)^ := crc;

    len := SynLZcompress1(P,PLen,R+9);

    if len>PLen then begin // store if compression not worth it

      R[4] := SYNLZCOMPRESS_STORED;

      PCardinal(R+5)^ := crc;

      MoveFast(P^,R[9],PLen);

      len := PLen;

    end else begin

      R[4] := SYNLZCOMPRESS_SYNLZ;

      PCardinal(R+5)^ := crc32c(0,pointer(R+9),len);

    end;

    if R=@tmp then

      SetString(result,tmp,len+9) else

      SetLength(result,len+9); // resize in-place may not move any data

  end;

end;



function SynLZDecompress(const Data: RawByteString): RawByteString;

begin

  SynLZDecompress(pointer(Data),Length(Data),result);

end;



procedure SynLZDecompress(P: PAnsiChar; PLen: integer; out Result: RawByteString);

var len: integer;

begin

  if (PLen<=9) or (P=nil) or (crc32c(0,pointer(P+9),PLen-9)<>PCardinal(P+5)^) then

    exit;

  case P[4] of

  SYNLZCOMPRESS_STORED:

    if PCardinal(P)^=PCardinal(P+5)^ then

      SetString(result,P+9,PLen-9);

  SYNLZCOMPRESS_SYNLZ: begin

    len := SynLZdecompressdestlen(P+9);

    SetLength(result,len);

    if (len<>0) and

       ((SynLZDecompress1(P+9,PLen-9,pointer(result))<>len) or

       (crc32c(0,pointer(result),len)<>PCardinal(P)^)) then

      result := '';

  end;

  end;

end;



function SynLZDecompress(const Data: RawByteString; out Len: integer;

  var tmp: RawByteString): pointer;

begin

  result := SynLZDecompress(pointer(Data),length(Data),Len,tmp);

end;



function SynLZDecompress(P: PAnsiChar; PLen: integer; out Len: integer;

  var tmp: RawByteString): pointer;

begin

  result := nil;

  if (PLen<=9) or (P=nil) or (crc32c(0,pointer(P+9),PLen-9)<>PCardinal(P+5)^) then

    exit;

  case P[4] of

  SYNLZCOMPRESS_STORED:

    if PCardinal(P)^=PCardinal(P+5)^ then begin

      result := P+9;

      Len := PLen-9;

    end;

  SYNLZCOMPRESS_SYNLZ: begin

    Len := SynLZdecompressdestlen(P+9);

    SetString(tmp,nil,Len);

    if (Len<>0) and

       (SynLZDecompress1(P+9,PLen-9,pointer(tmp))=Len) and

       (crc32c(0,pointer(tmp),Len)=PCardinal(P)^) then

      result := pointer(tmp);

  end;

  end;

end;



function SynLZCompressToBytes(const Data: RawByteString;

  CompressionSizeTrigger: integer): TByteDynArray;

begin

  result := SynLZCompressToBytes(pointer(Data),length(Data),CompressionSizeTrigger);

end;



function SynLZCompressToBytes(P: PAnsiChar; PLen,CompressionSizeTrigger: integer): TByteDynArray;

var len: integer;

    R: PAnsiChar;

    crc: cardinal;

begin

  if PLen=0 then

    exit;

  crc := crc32c(0,P,PLen);

  if PLen<CompressionSizeTrigger then begin

    SetLength(result,PLen+9);

    R := pointer(result);

    PCardinal(R)^ := crc;

    R[4] := SYNLZCOMPRESS_STORED;

    PCardinal(R+5)^ := crc;

    MoveFast(P^,R[9],PLen);

  end else begin

    SetLength(result,SynLZcompressdestlen(PLen)+9);

    R := pointer(result);

    PCardinal(R)^ := crc;

    len := SynLZcompress1(P,PLen,R+9);

    if len>PLen then begin // store if compression not worth it

      R[4] := SYNLZCOMPRESS_STORED;

      PCardinal(R+5)^ := crc;

      MoveFast(P^,R[9],PLen);

    end else begin

      R[4] := SYNLZCOMPRESS_SYNLZ;

      PCardinal(R+5)^ := crc32c(0,pointer(R+9),len);

    end;

    SetLength(result,len+9);

  end;

end;



function SynLZDecompress(const Data: TByteDynArray): RawByteString; overload;

begin

  SynLZDecompress(pointer(Data),length(Data),result);

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<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: TFileBufferWriter);

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; out Dest: RawByteString);

var PEnd,D,DEnd: PAnsiChar;

    DestLen,crc: cardinal;

begin

  PEnd := PAnsiChar(P)+Len-4;

  DestLen := FromVarUInt32(P);

  SetLength(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;





{ ESynException }



constructor ESynException.CreateUTF8(const Format: RawUTF8; const Args: array of const);

begin

  inherited Create(UTF8ToString(FormatUTF8(Format,Args)));

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;

begin

  i := length(Header);

  if i>0 then

    Dest.Write(pointer(Header)^,i);

  if fMap.Size>0 then

    Dest.Write(fMap.Buffer^,fMap.Size);

  if fAppendedLinesCount=0 then

    exit;

  W := TTextWriter.Create(Dest);

  try

    if (fMap.Size>0) and (fMap.Buffer[fMap.Size-1]>=' ') then

      W.Add(#13);

    for i := 0 to fAppendedLinesCount-1 do begin

      W.AddString(fAppendedLines[i]);

      W.Add(#13);

    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

    SetString(result,PAnsiChar(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: integer;

label Fnd;

begin

  if (p<>nil) and (up<>nil) then

  if pEnd=nil then

    repeat

      i := ord(p^);

      if not (AnsiChar(i) in ANSICHARNOT01310) then break;

      inc(p);

      if (NormToUpperAnsi7Byte[i]=ord(up^)) and IdemPChar(p,@up[1]) then begin

        result := true;

        exit;

      end;

    until false

  else

  repeat // fast unrolled search

    if p>=pEnd then break;

    i := ord(p^);

    if not (AnsiChar(i) in ANSICHARNOT01310) then break;

    if NormToUpperAnsi7Byte[i]=ord(up^) then goto Fnd;

    inc(p);

    if p>=pEnd then break;

    i := ord(p^);

    if not (AnsiChar(i) in ANSICHARNOT01310) then break;

    if NormToUpperAnsi7Byte[i]=ord(up^) then goto Fnd;

    inc(p);

    if p>=pEnd then break;

    i := ord(p^);

    if not (AnsiChar(i) in ANSICHARNOT01310) then break;

    if NormToUpperAnsi7Byte[i]=ord(up^) then goto Fnd;

    inc(p);

    if p>=pEnd then break;

    i := ord(p^);

    if not (AnsiChar(i) in ANSICHARNOT01310) then break;

    if NormToUpperAnsi7Byte[i]<>ord(up^) then begin

      inc(p);

      continue;

    end;

Fnd:i := 0;

    repeat

      inc(i);

      if up[i]=#0 then begin

        result := true; // found

        exit;

      end;

    until NormToUpperAnsi7[p[i]]<>up[i];

    inc(p);

  until false;

  result := false;

end;



function TMemoryMapText.LineContains(const aUpperSearch: RawUTF8;

  aIndex: Integer): Boolean;

begin

  if (self=nil) or (cardinal(aIndex)>=cardinal(fCount)) or (aUpperSearch='') then

    result := false else

    result := GetLineContains(fLines[aIndex],fMapEnd,pointer(aUpperSearch));

end;



function TMemoryMapText.LineSize(aIndex: integer): integer;

begin

  result := GetLineSize(fLines[aIndex],fMapEnd);

end;



function GetLineSizeSmallerThan(P,PEnd: PUTF8Char; aMinimalCount: integer): boolean;

begin

  if P<>nil then

    while (P<PEnd) and (P^ in ANSICHARNOT01310) 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

    inc(fLinesMax,256+fLinesMax shr 3);

    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<PEnd do begin

    PBeg := P;

    while (P<PEnd) and (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;





{ 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/458259

  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; // http://www.eecs.harvard.edu/~kirsch/pubs/bbbf/esa06.pdf

begin

  if (self=nil) or (aValueLen<=0) and (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

      SetBit(pointer(fStore)^,(h1+cardinal(h)*h2) mod fBits);

    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; // http://www.eecs.harvard.edu/~kirsch/pubs/bbbf/esa06.pdf

begin

  result := false;

  if (self=nil) or (aValueLen<=0) and (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 not GetBit(pointer(fStore)^,(h1+cardinal(h)*h2) mod fBits) then

        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;

begin

  W := TFileBufferWriter.Create(TRawByteStringStream,length(fStore)+100);

  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 := 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

    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 := DateTimeToUnixTime(NowUTC) 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;

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 (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 := crc32c(0,@head,sizeof(head)-sizeof(head.crc));

    if head.kind=bdUpToDate then begin

      SetString(result,PAnsiChar(@head),sizeof(head));

      exit;

    end;

    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)<sizeof(head^)) or (head.kind>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 (PLen<sizeof(head^)) or (head.kind>high(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;





{ TPendingTaskList }



constructor TPendingTaskList.Create;

begin

  fSafe.Init;

  fTasks.InitSpecific(TypeInfo(TPendingTaskListItemDynArray),fTask,djInt64,@fCount);

end;



destructor TPendingTaskList.Destroy;

begin

  fSafe.Done;

  inherited Destroy;

end;



function TPendingTaskList.GetTimeStamp: Int64;

begin

  result := 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 an 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 an 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;





{ TSynNameValue }



procedure TSynNameValue.Add(const aName, aValue: RawUTF8; aTag: PtrInt);

var added: boolean;

    i: Integer;

begin

  i := fDynArray.FindHashedForAdding(aName,added);

  with List[i] do begin

    if added then

      Name := aName;

    Value := aValue;

    Tag := aTag;

  end;

  if Assigned(fOnAdd) then

    fOnAdd(List[i],i);

end;



procedure TSynNameValue.InitFromIniSection(Section: PUTF8Char;

  OnTheFlyConvert: TConvertRawUTF8; OnAdd: TSynNameValueNotify);

var s: RawUTF8;

    i: integer;

begin

  Init(false);                         

  fOnAdd := OnAdd;

  while (Section<>nil) and (Section^<>'[') do begin

    s := GetNextLine(Section,Section);

    i := PosEx('=',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

    n := GetNextItem(CSV,NameValueSep);

    v := GetNextItem(CSV,ItemSep);

    if n='' then

      break;

    Add(n,v);

  end;

end;



procedure TSynNameValue.Init(aCaseSensitive: boolean);

begin

  List := nil; // release dynamic arrays memory before Fillchar()

  fDynArray.fHashs := nil;

  FillcharFast(self,sizeof(self),0);

  fDynArray.InitSpecific(TypeInfo(TSynNameValueItemDynArray),List,

    djRawUTF8,@Count,not aCaseSensitive);

end;



function TSynNameValue.Find(const aName: RawUTF8): integer;

begin

  result := fDynArray.FindHashed(aName);

end;



function TSynNameValue.FindStart(const aUpperName: RawUTF8): integer;

begin

  for result := 0 to Count-1 do

    if IdemPChar(pointer(List[result].Name),pointer(aUpperName)) then

      exit;

  result := -1;

end;



function TSynNameValue.FindByValue(const aValue: RawUTF8): integer;

begin

  for result := 0 to Count-1 do

    if List[result].Value=aValue then

      exit;

  result := -1;

end;



function TSynNameValue.Delete(const aName: RawUTF8): boolean;

var ndx: integer;

begin

  ndx := fDynArray.FindHashed(aName);

  if ndx>=0 then begin

    fDynArray.Delete(ndx);

    fDynArray.ReHash;

    result := true;

  end else

    result := false;

end;



function TSynNameValue.DeleteByValue(const aValue: RawUTF8; Limit: integer): integer;

var ndx: integer;

begin

  result := 0;

  if Limit<1 then

    exit;

  for ndx := Count-1 downto 0 do

    if List[ndx].Value=aValue then begin

      fDynArray.Delete(ndx);

      inc(result);

      if result>=Limit then

        break;

    end;

  if result>0 then

    fDynArray.ReHash;

end;



function TSynNameValue.Value(const aName: RawUTF8; const aDefaultValue: RawUTF8): RawUTF8;

var i: integer;

begin

  if @self=nil then

    i := -1 else

    i := fDynArray.FindHashed(aName);

  if i<0 then

    result := aDefaultValue else

    result := List[i].Value;

end;



function TSynNameValue.ValueInt(const aName: RawUTF8; const aDefaultValue: Int64): Int64;

var i,err: integer;

begin

  i := fDynArray.FindHashed(aName);

  if i<0 then

    result := aDefaultValue else begin

    result := GetInt64(pointer(List[i].Value),err);

    if err<>0 then

      result := aDefaultValue;

  end;

end;



function TSynNameValue.ValueBool(const aName: RawUTF8): Boolean;

begin

  result := Value(aName)='1';

end;



function TSynNameValue.Initialized: boolean;

begin

  result := fDynArray.fValue=@List;

end;



function TSynNameValue.GetBlobData: RawByteString;

begin

  result := fDynArray.SaveTo;

end;



procedure TSynNameValue.SetBlobDataPtr(aValue: pointer);

begin

  fDynArray.LoadFrom(aValue);

  fDynArray.ReHash;

end;



procedure TSynNameValue.SetBlobData(const aValue: RawByteString);

begin

  SetBlobDataPtr(pointer(aValue));

end;



function TSynNameValue.GetStr(const aName: RawUTF8): RawUTF8;

begin

  result := Value(aName,'');

end;



function TSynNameValue.GetInt(const aName: RawUTF8): Int64;

begin

  result := ValueInt(aName,0);

end;



function TSynNameValue.GetBool(const aName: RawUTF8): Boolean;

begin

  result := Value(aName)='1';

end;



function TSynNameValue.AsCSV(const KeySeparator,ValueSeparator,IgnoreKey: RawUTF8): RawUTF8;

var i: integer;

begin

  with TTextWriter.CreateOwnedStream 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;



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: 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])) 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: Boolean): integer;

var DV: TDocVariantData absolute DocVariant;

    i,ndx: integer;

    v: variant;

begin

  if DV.VType<>DocVariantVType then

    TDocVariant.New(DocVariant,JSON_OPTIONS_NAMEVALUE[ExtendedJson]);

  if ChangedProps<>nil then

    TDocVariant.New(ChangedProps^,DV.Options);

  result := 0; // returns number of changed values

  for i := 0 to Count-1 do begin

    VarClear(v);

    if ValueAsString or

       not GetNumericVariantFromJSON(pointer(List[i].Value),TVarData(v)) 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]);

    inc(result);

  end;

end;

{$endif}





{ TSynAuthenticationAbstract }



constructor TSynAuthenticationAbstract.Create;

begin

  fSafe.Init;

  fTokenSeed := GetTickCount64*PtrUInt(self)*Random(maxInt);

  fSessionGenerator := abs(fTokenSeed*PtrUInt(ClassType));

end;



destructor TSynAuthenticationAbstract.Destroy;

begin

  fSafe.Done;

  inherited;

end;



class function TSynAuthenticationAbstract.ComputeHash(Token: Int64;

  const UserName,PassWord: RawUTF8): cardinal;

begin // rough authentication - better than nothing

  result := length(UserName);

  result := crc32c(crc32c(crc32c(result,@Token,sizeof(Token)),

    pointer(UserName),result),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.CreateFmt('%.AuthenticateUser() is not implemented',[self]);

end;



procedure TSynAuthenticationAbstract.DisauthenticateUser(const aName: RawUTF8);

begin

  raise ESynException.CreateFmt('%.DisauthenticateUser() is not implemented',[self]);

end;



function TSynAuthenticationAbstract.CreateSession(const User: RawUTF8; Hash: cardinal): integer;

var password: RawUTF8;

begin

  result := 0;

  fSafe.Lock;

  try

    // check the credentials

    if not GetPassword(User,password) then

      exit;

    if (ComputeCredential(false,User,password)<>Hash) and

       (ComputeCredential(true,User,password)<>Hash) then

      exit;

    // create the new session

    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;





{ 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: cardinal;

begin

  result := Value shr 31;

end;



{$ifndef NOVARIANTS}

function TSynUniqueIdentifierBits.AsVariant: variant;

begin

  result := _ObjFast(['Created',DateTimeToIso8601Text(CreateDateTime),

    'Identifier',ProcessID,'Counter',Counter,'Value',Value,

    'Hex',Int64ToHex(Value)]);

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(aDateTime: TDateTime);

begin

  Value := DateTimeToUnixTime(aDateTime) shl 31;

end;





{ TSynUniqueIdentifierGenerator }



const // fSafe.Padding[] slots

  SYNUNIQUEGEN_COMPUTECOUNT = 0;

  

procedure TSynUniqueIdentifierGenerator.ComputeNew(

  out result: TSynUniqueIdentifierBits);

var tix, currentTime: cardinal;

begin

  tix := GetTickCount64 shr 8; // retrieve time every 256 ms

  fSafe.Lock;

  try

    if tix<>fLastTix then begin

      fLastTix := tix;

      currentTime := DateTimeToUnixTime(NowUTC);

      if currentTime>fUnixCreateTime then begin

        fUnixCreateTime := currentTime;

        fLastCounter := 0; // reset

      end;

    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(aDateTime: TDateTime;

  out result: TSynUniqueIdentifierBits);

begin // assume fLastCounter=0

  result.Value := (DateTimeToUnixTime(aDateTime) shl 31) or fIdentifierShifted;

end;



procedure TSynUniqueIdentifierGenerator.ComputeFromUnixTime(aUnixTime: Int64;

  out result: TSynUniqueIdentifierBits);

begin // assume fLastCounter=0

  result.Value := (aUnixTime shl 31) 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;

  {$ifdef NOVARIANTS}

  variant(fSafe.Padding[SYNUNIQUEGEN_COMPUTECOUNT]) := 0;

  {$else}

  fSafe.LockedInt64[SYNUNIQUEGEN_COMPUTECOUNT] := 0;

  {$endif}

  // 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;

  inherited Destroy;

end;



type // used to compute a 24 hexadecimal chars 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 := PosEx('.',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;





{ TSynBackgroundThreadAbstract }



{$ifdef MSWINDOWS}

function IsDebuggerPresent: BOOL; stdcall; external kernel32; // since XP

{$endif}



procedure SetCurrentThreadName(const Format: RawUTF8; const Args: array of const);

begin

  SetThreadName(GetCurrentThreadId,Format,Args);

end;



procedure SetThreadName(ThreadID: TThreadID; const Format: RawUTF8;

  const Args: array of const);

var name: RawUTF8;

begin

  FormatUTF8(Format,Args,name);

  SetThreadNameInternal(ThreadID,name);

end;



procedure SetThreadNameDefault(ThreadID: TThreadID; const Name: RawUTF8);

var s: RawByteString;

    {$ifndef ISDELPHIXE2}

    {$ifdef MSWINDOWS}

    info: record

      FType: LongWord;     // must be 0x1000

      FName: PAnsiChar;    // pointer to name (in user address space)

      FThreadID: LongWord; // thread ID (-1 indicates caller thread)

      FFlags: LongWord;    // reserved for future use, must be zero

    end;

    {$endif}

    {$endif}

begin

  {$ifdef FPC}

  exit;

  {$endif}

  {$ifdef NOSETTHREADNAME}

  exit;

  {$endif}

  {$ifdef MSWINDOWS}

  if not IsDebuggerPresent then

    exit;

  {$endif}

  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}

  {$endif}

end;



constructor TSynBackgroundThreadAbstract.Create(const aThreadName: RawUTF8;

  OnBeforeExecute,OnAfterExecute: TNotifyThreadEvent);

begin

  fProcessEvent := TEvent.Create(nil,false,false,'');

  fThreadName := aThreadName;

  fOnBeforeExecute := OnBeforeExecute;

  fOnAfterExecute := OnAfterExecute;

  InitializeCriticalSection(fPendingProcessLock);

  inherited Create(false{$ifdef FPC},512*1024{$endif}); // DefaultStackSize=512KB

end;



{$ifdef KYLIX3}

type

  // see http://stackoverflow.com/a/3085509/458259 about the Kylix only 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

       sched_yield 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 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;



destructor TSynBackgroundThreadAbstract.Destroy;

begin

  FreeAndNil(fProcessEvent);

  DeleteCriticalSection(fPendingProcessLock);

  inherited Destroy;

end;



procedure TSynBackgroundThreadAbstract.Execute;

begin

  try

    if fThreadName='' then

      SetCurrentThreadName('%(%)',[self,pointer(self)]) else

      SetCurrentThreadName('%',[fThreadName]);

    if Assigned(fOnBeforeExecute) then

      fOnBeforeExecute(self);

    try

      while not Terminated do

        ExecuteLoop;

    finally

      if Assigned(fOnAfterExecute) then

        fOnAfterExecute(self);

    end;

  finally

    fExecuteFinished := true;

  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,'');

  inherited Create(aThreadName,OnBeforeExecute,OnAfterExecute);

end;



destructor TSynBackgroundThreadMethodAbstract.Destroy;

begin

  SetPendingProcess(flagDestroying);

  fProcessEvent.SetEvent;  // notify terminated

  FixedWaitForever(fCallerEvent);

  FreeAndNil(fCallerEvent);

  inherited Destroy;

end;



function TSynBackgroundThreadMethodAbstract.GetPendingProcess: TSynBackgroundThreadProcessStep;

begin

  EnterCriticalSection(fPendingProcessLock);

  result := fPendingProcessFlag;

  LeaveCriticalSection(fPendingProcessLock);

end;



procedure TSynBackgroundThreadMethodAbstract.SetPendingProcess(State: TSynBackgroundThreadProcessStep);

begin

  EnterCriticalSection(fPendingProcessLock);

  fPendingProcessFlag := State;

  LeaveCriticalSection(fPendingProcessLock);

end;



procedure TSynBackgroundThreadMethodAbstract.ExecuteLoop;

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

      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}

          fBackgroundException := AcquireExceptionObject;

          {$endif}

        end;

      finally

        SetPendingProcess(flagFinished);

        fCallerEvent.SetEvent;

      end;

     end;

  end;

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;



function TSynBackgroundThreadMethodAbstract.AcquireThread: TSynBackgroundThreadProcessStep;

begin

  EnterCriticalSection(fPendingProcessLock);

  try

    result := fPendingProcessFlag;

    if result=flagIdle then begin // we just acquired the thread! congrats!

      fPendingProcessFlag := flagStarted; // atomic set "started" flag

      fCallerThreadID := ThreadID;

    end;

  finally

    LeaveCriticalSection(fPendingProcessLock);

  end;

end;



function TSynBackgroundThreadMethodAbstract.OnIdleProcessNotify(start: Int64): integer;

begin

  result := 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);

var E: Exception;

begin

  if (self=nil) or not (fPendingProcessFlag in [flagStarted, flagFinished]) then

    exit; // nothing to wait for

  try

    {$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 := 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);

    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); // wait for flagFinished, then set flagIdle

  result := true;

end;



function TSynBackgroundThreadMethodAbstract.GetOnIdleBackgroundThreadActive: boolean;

begin

  result := (self<>nil) and Assigned(fOnIdle) and (GetPendingProcess<>flagIdle);

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);

begin

  if not Assigned(aOnProcess) then

    raise ESynException.CreateUTF8('%.Create(aOnProcess=nil)',[self]);

  if aStats<>nil then

    fStats := aStats.Create(aThreadName) else

    fStats := TSynMonitor.Create(aThreadName);

  fOnProcess := aOnProcess;

  fOnProcessMS := aOnProcessMS;

  if fOnProcessMS=0 then

    fOnProcessMS := INFINITE; // wait until ProcessEvent.SetEvent or Terminated

  inherited Create(aThreadName,aOnBeforeExecute,aOnAfterExecute);

end;



destructor TSynBackgroundThreadProcess.Destroy;

begin

  if not fExecuteFinished then begin

    Terminate;

    fProcessEvent.SetEvent;  // notify terminated

    while not fExecuteFinished do

      Sleep(1);

  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

    try

      fStats.ProcessStartTask;

      try

        fOnProcess(self,wait);

      finally

        fStats.ProcessEnd;

      end;

    except

      on E: Exception do begin

        fStats.ProcessError({$ifdef NOVARIANTS}E.ClassName{$else}ObjectToVariant(E){$endif});

        if Assigned(fOnException) then

          fOnException(E);

      end;

    end;

end;





{ TSynParallelProcess }



constructor TSynParallelProcess.Create(ThreadPoolCount: integer; const ThreadName: RawUTF8;

  OnBeforeExecute, OnAfterExecute: TNotifyThreadEvent);

var i: integer;

begin

  inherited Create;

  if ThreadPoolCount<0 then

    raise ESynParallelProcess.CreateUTF8('%.Create(%,%)',[Self,ThreadPoolCount,ThreadName]);

  if ThreadPoolCount>32 then

    ThreadPoolCount := 32;

  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(Method: TSynParallelProcessMethod;

  MethodCount: integer);

var use,t,n,perthread: integer;

    error: RawUTF8;

begin

  if (MethodCount<=0) or not Assigned(Method) then

    exit;

  if (self=nil) or (MethodCount=1) or (fThreadPoolCount=0) then begin

    Method(0,0); // no need to use a background thread here

    exit;

  end;

  use := MethodCount;

  if use>fThreadPoolCount+1 then // +1 to include current thread

    use := fThreadPoolCount+1;

  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;

        Sleep(1);

      until false;

      fPool[t].Start(Method,n,n+perthread-1);

      inc(n,perthread);

      inc(fParallelRunCount);

    end;

    // run remaining items in the current thread

    if n<MethodCount then begin

      Method(n,MethodCount-1);

      inc(fParallelRunCount);

    end;

  finally

    // wait for the process to finish

    for t := 0 to use-2 do

    try

      fPool[t].WaitForFinished(0);

    except

      on E: Exception do

        error := FormatUTF8('% % on thread % [%]',[error,E,fPool[t].fThreadName,E.Message]);

    end;

    if error<>'' then

      raise ESynParallelProcess.CreateUTF8('%.ParallelRunAndWait: %',[self,error]);

  end;

end;





{ TBlockingProcess }



constructor TBlockingProcess.Create(aTimeOutMs: integer; const aSafe: TSynLocker);

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 := TAutoLocker.Create;

  Create(aTimeOutMS,fOwnedSafe.fSafe);

end;



destructor TBlockingProcess.Destroy;

begin

  fOwnedSafe.Free;

  inherited Destroy;

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 := TObjectListLocked.Create(true);

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

    sleep(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;





{ 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)<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: integer;

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;



var

  GarbageCollectorFreeAndNilList: TList;



procedure GarbageCollectorFree;

var i: integer;

begin

  if GarbageCollectorFreeing then

    exit; // when already called before finalization

  GarbageCollectorFreeing := true;

  for i := GarbageCollector.Count-1 downto 0 do // last in, first out

  try

    GarbageCollector.Delete(i); // will call GarbageCollector[i].Free

  except

    on Exception do

      ; // just ignore exceptions in client code destructors

  end;

  for i := GarbageCollectorFreeAndNilList.Count-1 downto 0 do // LIFO

  try

    if PObject(GarbageCollectorFreeAndNilList.List[i])^<>nil then

      FreeAndNil(PObject(GarbageCollectorFreeAndNilList.List[i])^);

  except

    on E: Exception do

      ; // just ignore exceptions in client code destructors

  end;

  FreeAndNil(GarbageCollectorFreeAndNilList);

end;



procedure GarbageCollectorFreeAndNil(var InstanceVariable; Instance: TObject);

begin

  TObject(InstanceVariable) := Instance;

  GarbageCollectorFreeAndNilList.Add(@InstanceVariable);

end;



var

  GlobalCriticalSection: TRTLCriticalSection;



procedure GlobalLock;

begin

  EnterCriticalSection(GlobalCriticalSection);

end;



procedure GlobalUnLock;

begin

  LeaveCriticalSection(GlobalCriticalSection);

end;



{$ifdef CPUINTEL}

procedure TestIntelCpuFeatures;

var regs: TRegisters;

begin

  regs.edx := 0;

  regs.ecx := 0;

  GetCPUID(1,regs);

  PIntegerArray(@CpuFeatures)^[0] := regs.edx;

  PIntegerArray(@CpuFeatures)^[1] := regs.ecx;

  GetCPUID(7,regs);

  PIntegerArray(@CpuFeatures)^[2] := regs.ebx;

  PByteArray(@CpuFeatures)^[12] := regs.ecx;

end;

{$endif CPUINTEL}



procedure InitSynCommonsConversionTables;

var i,n: integer;

    v: byte;

    crc: cardinal;

{$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';

begin

  JSON_CONTENT_TYPE_VAR := JSON_CONTENT_TYPE;

  JSON_CONTENT_TYPE_HEADER_VAR := JSON_CONTENT_TYPE_HEADER;

  {$ifdef FPC}

  {$ifdef ISFPC27}

  SetMultiByteConversionCodePage(CP_UTF8);

  SetMultiByteRTLFileSystemCodePage(CP_UTF8);

  {$endif}

  {$endif FPC}

  {$ifdef KYLIX3}

  // if default locale is set to *.UTF-8, which is the case in most modern

  // linux default configuration, unicode decode will fail in SysUtils.CheckLocale

  setlocale(LC_CTYPE,'en_US'); // force locale for a UTF-8 server

  {$endif}

{$ifndef EXTENDEDTOSTRING_USESTR}

  {$ifdef ISDELPHIXE}

  SettingsUS := TFormatSettings.Create($0409);

  {$else}

  GetLocaleFormatSettings($0409,SettingsUS);

  {$endif}

  SettingsUS.DecimalSeparator := '.'; // value may have been overriden :(

{$endif}

  for i := 0 to 255 do

    NormToUpperAnsi7Byte[i] := i;

  for i := ord('a') to ord('z') do

    dec(NormToUpperAnsi7Byte[i],32);

{$ifdef OWNNORMTOUPPER}

  // initialize custom NormToUpper[] and NormToLower[] arrays

  MoveFast(NormToUpperAnsi7,NormToUpper,138);

  MoveFast(n2u,NormToUpperByte[138],sizeof(n2u));

  for i := 0 to 255 do begin

    d := NormToUpperByte[i];

    if d in [ord('A')..ord('Z')] then

      inc(d,32);

    NormToLowerByte[i] := d;

  end;

{$endif OWNNORMTOUPPER}

  // code below is 55 bytes long, therefore shorter than a const array

  FillcharFast(ConvertHexToBin[0],sizeof(ConvertHexToBin),255); // all to 255

  v := 0;

  for i := ord('0') to ord('9') do begin

    ConvertHexToBin[i] := v;

    inc(v);

  end;

  for i := ord('A') to ord('F') do begin

    ConvertHexToBin[i] := v;

    ConvertHexToBin[i+(ord('a')-ord('A'))] := v;

    inc(v);

  end;

  for i := 0 to 255 do begin

    TwoDigitsHex[i][1] := HexChars[i shr 4];

    TwoDigitsHex[i][2] := HexChars[i and $f];

  end;

  FillcharFast(ConvertBase64ToBin,256,255); // invalid value set to -1

  for i := 0 to high(b64) do

    ConvertBase64ToBin[b64[i]] := i;

  ConvertBase64ToBin['='] := -2; // special value for '='

  for i := high(B2A) downto 0 do

    if B2A[i]<#128 then

      A2B[B2A[i]] := i;

  for i := ord('a') to ord('z') do

    A2B[AnsiChar(i-32)] := A2B[AnsiChar(i)]; // A-Z -> a-z

  // initialize our internaly used TSynAnsiConvert engines

  TSynAnsiConvert.Engine(0);

  // initialize tables for crc32cfast() and SymmetricEncrypt/FillRandom

  for i := 0 to 255 do begin

    crc := i;

    for n := 1 to 8 do

      if (crc and 1)<>0 then // polynom is not the same as with zlib's crc32()

        crc := (crc shr 1) xor $82f63b78 else

        crc := crc shr 1;

    crc32ctab[0,i] := crc;

  end;

  for i := 0 to 255 do begin

    crc := crc32ctab[0,i];

    for n := 1 to high(crc32ctab) do begin

      crc := (crc shr 8) xor crc32ctab[0,ToByte(crc)];

      crc32ctab[n,i] := crc;

    end;

  end;

  UpperCopy255Buf := @UpperCopy255BufPas;

  {$ifdef CPUINTEL}

  if cfSSE42 in CpuFeatures then begin

    crc32c := @crc32csse42;

    {$ifndef PUREPASCAL}

    StrComp := @StrCompSSE42;

    DYNARRAY_SORTFIRSTFIELD[false,djRawUTF8] := @SortDynArrayAnsiStringSSE42;

    DYNARRAY_SORTFIRSTFIELD[false,djWinAnsi] := @SortDynArrayAnsiStringSSE42;

    DYNARRAY_SORTFIRSTFIELD[false,djRawByteString] := @SortDynArrayAnsiStringSSE42;

    {$ifndef UNICODE}

    DYNARRAY_SORTFIRSTFIELD[false,djString] := @SortDynArrayAnsiStringSSE42;

    {$endif}

    DYNARRAY_SORTFIRSTFIELDHASHONLY[true] := @SortDynArrayAnsiStringSSE42;

    {$ifndef DELPHI5OROLDER}

    UpperCopy255Buf := @UpperCopy255BufSSE42;

    {$endif}

    {$endif PUREPASCAL}

  end else

  {$endif CPUINTEL}

    crc32c := @crc32cfast;

  DefaultHasher := crc32c;

end;





initialization

  // initialization of global variables

  GarbageCollectorFreeAndNilList := TList.Create;

  GarbageCollectorFreeAndNil(GarbageCollector,TObjectList.Create);

  InitializeCriticalSection(GlobalCriticalSection);

  {$ifdef CPUINTEL}

  TestIntelCpuFeatures;

  {$endif}

  MoveFast := @System.Move;

  {$ifdef FPC}

  FillCharFast := @System.FillChar;

  {$else}

  {$ifdef CPUARM}

  FillCharFast := @System.FillChar;

  {$else}

  {$ifdef USEPACKAGES}

  Pointer(@FillCharFast) := SystemFillCharAddress;

  {$else}

  InitRedirectCode;

  {$endif USEPACKAGES}

  {$endif CPUARM}

  {$endif FPC}

  InitSynCommonsConversionTables;

  RetrieveSystemInfo;

  SetExecutableVersion(0,0,0,0);

  TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TFindFilesDynArray),

    'Name string Attr Integer Size Int64 TimeStamp TDateTime');

  // some type definition assertions

  Assert(SizeOf(TSynTableFieldType)=1); // as expected by TSynTableFieldProperties

  Assert(SizeOf(TSynTableFieldOptions)=1);

  {$ifndef NOVARIANTS}

  Assert(SizeOf(TSynTableData)=sizeof(TVarData));

  Assert(SizeOf(TDocVariantData)=sizeof(TVarData));

  {$endif NOVARIANTS}

  {$warnings OFF}

  Assert((MAX_SQLFIELDS>=64)and(MAX_SQLFIELDS<=256));

  {$warnings ON}

  Assert(sizeof(TSynUniqueIdentifierBits)=sizeof(TSynUniqueIdentifier));

{  TypeInfoSaveRegisterKnown([

    TypeInfo(boolean),TypeInfo(byte),TypeInfo(word),TypeInfo(cardinal),TypeInfo(Int64),

    TypeInfo(single),TypeInfo(double),TypeInfo(currency),TypeInfo(extended),TypeInfo(TDateTime),

    TypeInfo(RawByteString),TypeInfo(RawJSON),TypeInfo(RawUTF8),TypeInfo(string),

    TypeInfo(SynUnicode),TypeInfo(WideString)]); }



finalization

  GarbageCollectorFree;

  DeleteCriticalSection(GlobalCriticalSection);

  //writeln('TDynArrayHashedCollisionCount=',TDynArrayHashedCollisionCount); readln;

end.