Delphi/delphimvcframework
1
0
Fork 0
mirror of https://github.com/danieleteti/delphimvcframework.git synced 2024-11-16 00:05:53 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity
7175c4dc3f
delphimvcframework/lib/dmustache/SynCommons.pas
Daniele Teti ff385631a8 Updated DMustache ext lib
2022-08-19 10:19:22 +02:00

63349 lines
2.1 MiB
Raw Blame History

/// common functions used by most Synopse projects
// - this unit is a part of the freeware Synopse mORMot framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit SynCommons;
(*
This file is part of Synopse framework.
Synopse framework. Copyright (C) 2022 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
Version: MPL 1.1/GPL 2.0/LGPL 2.1
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
for the specific language governing rights and limitations under the License.
The Original Code is Synopse framework.
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2022
the Initial Developer. All Rights Reserved.
Contributor(s):
- Alan Chate
- Aleksandr (sha)
- Alfred Glaenzer (alf)
- ASiwon
- Chaa
- BigStar
- Eugene Ilyin
- f-vicente
- itSDS
- Johan Bontes
- kevinday
- Kevin Chen
- Maciej Izak (hnb)
- Marius Maximus (mariuszekpl)
- mazinsw
- mingda
- PBa
- RalfS
- Sanyin
- Pavel Mashlyakovskii (mpv)
- Wloochacz
- zed
Alternatively, the contents of this file may be used under the terms of
either the GNU General Public License Version 2 or later (the "GPL"), or
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
in which case the provisions of the GPL or the LGPL are applicable instead
of those above. If you wish to allow use of your version of this file only
under the terms of either the GPL or the LGPL, and not to allow others to
use your version of this file under the terms of the MPL, indicate your
decision by deleting the provisions above and replace them with the notice
and other provisions required by the GPL or the LGPL. If you do not delete
the provisions above, a recipient may use your version of this file under
the terms of any one of the MPL, the GPL or the LGPL.
***** END LICENSE BLOCK *****
*)
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
interface
uses
{$ifdef MSWINDOWS}
Windows,
Messages,
{$else MSWINDOWS}
{$ifdef KYLIX3}
Types,
LibC,
SynKylix,
{$endif KYLIX3}
{$ifdef FPC}
BaseUnix,
{$endif FPC}
{$endif MSWINDOWS}
Classes,
{$ifndef LVCL}
SyncObjs, // for TEvent and TCriticalSection
Contnrs, // for TObjectList
{$ifdef HASINLINE}
Types,
{$endif HASINLINE}
{$endif LVCL}
{$ifndef NOVARIANTS}
Variants,
{$endif NOVARIANTS}
SynLZ, // needed for TSynMapFile .mab format
SysUtils;
const
/// the corresponding version of the freeware Synopse framework
// - includes a commit increasing number (generated by SourceCodeRep tool)
// - a similar constant shall be defined in SynCrtSock.pas
SYNOPSE_FRAMEWORK_VERSION = {$I SynopseCommit.inc};
/// a text including the version and the main active conditional options
// - usefull for low-level debugging purpose
SYNOPSE_FRAMEWORK_FULLVERSION = SYNOPSE_FRAMEWORK_VERSION
{$ifdef FPC}
{$ifdef FPC_X64MM}+' x64MM'{$ifdef FPCMM_BOOST}+'b'{$endif}
{$ifdef FPCMM_SERVER}+'s'{$endif}{$else}
{$ifdef FPC_FASTMM4}+' FMM4'{$else}
{$ifdef FPC_SYNTBB}+' TBB'{$else}
{$ifdef FPC_SYNJEMALLOC}+' JM'{$else}
{$ifdef FPC_SYNCMEM}+' CM'{$else}
{$ifdef FPC_CMEM}+' cM'{$endif}{$endif}{$endif}{$endif}{$endif}{$endif}
{$else}
{$ifdef LVCL}+' LVCL'{$else}
{$ifdef ENHANCEDRTL}+' ERTL'{$endif}{$endif}
{$ifdef FullDebugMode}+' FDM'{$endif}
{$endif FPC}
{$ifdef DOPATCHTRTL}+' PRTL'{$endif};
{ ************ common types used for compatibility between compilers and CPU }
const
/// internal Code Page for UTF-16 Unicode encoding
// - used e.g. for Delphi 2009+ UnicodeString=String type
CP_UTF16 = 1200;
/// fake code page used to recognize TSQLRawBlob
// - as returned e.g. by TTypeInfo.AnsiStringCodePage from mORMot.pas
CP_SQLRAWBLOB = 65534;
/// internal Code Page for RawByteString undefined string
CP_RAWBYTESTRING = 65535;
/// US English Windows Code Page, i.e. WinAnsi standard character encoding
CODEPAGE_US = 1252;
/// Latin-1 ISO/IEC 8859-1 Code Page
CODEPAGE_LATIN1 = 819;
{$ifndef MSWINDOWS}
/// internal Code Page for UTF-8 Unicode encoding
CP_UTF8 = 65001;
var
/// contains the curent system code page (default WinAnsi)
GetACP: integer = CODEPAGE_US;
{$endif}
{$ifdef FPC} { make cross-compiler and cross-CPU types available to Delphi }
type
PBoolean = ^Boolean;
{$else FPC}
type
{$ifdef CPU64} // Delphi XE2 seems stable about those types (not Delphi 2009)
PtrInt = NativeInt;
PtrUInt = NativeUInt;
{$else}
/// a CPU-dependent signed integer type cast of a pointer / register
// - used for 64-bit compatibility, native under Free Pascal Compiler
PtrInt = integer;
/// a CPU-dependent unsigned integer type cast of a pointer / register
// - used for 64-bit compatibility, native under Free Pascal Compiler
PtrUInt = cardinal;
{$endif}
/// a CPU-dependent unsigned integer type cast of a pointer of pointer
// - used for 64-bit compatibility, native under Free Pascal Compiler
PPtrUInt = ^PtrUInt;
/// a CPU-dependent signed integer type cast of a pointer of pointer
// - used for 64-bit compatibility, native under Free Pascal Compiler
PPtrInt = ^PtrInt;
/// unsigned Int64 doesn't exist under older Delphi, but is defined in FPC
// - and UInt64 is buggy as hell under Delphi 2007 when inlining functions:
// older compilers will fallback to signed Int64 values
// - anyway, consider using SortDynArrayQWord() to compare QWord values
// in a safe and efficient way, under a CPUX86
// - you may use UInt64 explicitly in your computation (like in SynEcc.pas),
// if you are sure that Delphi 6-2007 compiler handles your code as expected,
// but mORMot code will expect to use QWord for its internal process
// (e.g. ORM/SOA serialization)
{$ifdef UNICODE}
QWord = UInt64;
{$else}
QWord = {$ifndef DELPHI5OROLDER}type{$endif} Int64;
{$endif}
/// points to an unsigned Int64
PQWord = ^QWord;
{$ifndef ISDELPHIXE2}
/// used to store the handle of a system Thread
TThreadID = cardinal;
{$endif}
{$endif FPC}
{$ifdef DELPHI6OROLDER}
// some definitions not available prior to Delphi 7
type
UInt64 = Int64;
{$endif}
{$ifdef DELPHI5OROLDER}
// Delphi 5 doesn't have those basic types defined :(
const
varShortInt = $0010;
varInt64 = $0014; { vt_i8 }
soBeginning = soFromBeginning;
soCurrent = soFromCurrent;
reInvalidPtr = 2;
PathDelim = '\';
sLineBreak = #13#10;
type
PPointer = ^Pointer;
PPAnsiChar = ^PAnsiChar;
PInteger = ^Integer;
PCardinal = ^Cardinal;
PByte = ^Byte;
PWord = ^Word;
PBoolean = ^Boolean;
PDouble = ^Double;
PComp = ^Comp;
THandle = LongWord;
PVarData = ^TVarData;
TVarData = packed record
// mostly used for varNull, varInt64, varDouble, varString and varAny
VType: word;
case Integer of
0: (Reserved1: Word;
case Integer of
0: (Reserved2, Reserved3: Word;
case Integer of
varSmallInt: (VSmallInt: SmallInt);
varInteger: (VInteger: Integer);
varSingle: (VSingle: Single);
varDouble: (VDouble: Double); // DOUBLE
varCurrency: (VCurrency: Currency);
varDate: (VDate: TDateTime);
varOleStr: (VOleStr: PWideChar);
varDispatch: (VDispatch: Pointer);
varError: (VError: HRESULT);
varBoolean: (VBoolean: WordBool);
varUnknown: (VUnknown: Pointer);
varByte: (VByte: Byte);
varInt64: (VInt64: Int64); // INTEGER
varString: (VString: Pointer); // TEXT
varAny: (VAny: Pointer);
varArray: (VArray: PVarArray);
varByRef: (VPointer: Pointer);
);
1: (VLongs: array[0..2] of LongInt); );
end;
{$else}
{$ifndef FPC}
type
// redefined here to not use the wrong definitions from Windows.pas
PWord = System.PWord;
PSingle = System.PSingle;
{$endif FPC}
{$endif DELPHI5OROLDER}
type
/// RawUnicode is an Unicode String stored in an AnsiString
// - faster than WideString, which are allocated in Global heap (for COM)
// - an AnsiChar(#0) is added at the end, for having a true WideChar(#0) at ending
// - length(RawUnicode) returns memory bytes count: use (length(RawUnicode) shr 1)
// for WideChar count (that's why the definition of this type since Delphi 2009
// is AnsiString(1200) and not UnicodeString)
// - pointer(RawUnicode) is compatible with Win32 'Wide' API call
// - mimic Delphi 2009 UnicodeString, without the WideString or Ansi conversion overhead
// - all conversion to/from AnsiString or RawUTF8 must be explicit: the
// compiler is not able to make valid implicit conversion on CP_UTF16
{$ifdef HASCODEPAGE}
RawUnicode = type AnsiString(CP_UTF16); // Codepage for an UnicodeString
{$else}
RawUnicode = type AnsiString;
{$endif}
/// RawUTF8 is an UTF-8 String stored in an AnsiString
// - use this type instead of System.UTF8String, which behavior changed
// between Delphi 2009 compiler and previous versions: our implementation
// is consistent and compatible with all versions of Delphi compiler
// - mimic Delphi 2009 UTF8String, without the charset conversion overhead
// - all conversion to/from AnsiString or RawUnicode must be explicit
{$ifdef HASCODEPAGE}
RawUTF8 = type AnsiString(CP_UTF8); // Codepage for an UTF8 string
{$else}
RawUTF8 = type AnsiString;
{$endif}
/// WinAnsiString is a WinAnsi-encoded AnsiString (code page 1252)
// - use this type instead of System.String, which behavior changed
// between Delphi 2009 compiler and previous versions: our implementation
// is consistent and compatible with all versions of Delphi compiler
// - all conversion to/from RawUTF8 or RawUnicode must be explicit
{$ifdef HASCODEPAGE}
WinAnsiString = type AnsiString(CODEPAGE_US); // WinAnsi Codepage
{$else}
WinAnsiString = type AnsiString;
{$endif}
{$ifdef HASCODEPAGE}
{$ifdef FPC}
// missing declaration
PRawByteString = ^RawByteString;
{$endif}
{$else}
/// define RawByteString, as it does exist in Delphi 2009+
// - to be used for byte storage into an AnsiString
// - use this type if you don't want the Delphi compiler not to do any
// code page conversions when you assign a typed AnsiString to a RawByteString,
// i.e. a RawUTF8 or a WinAnsiString
RawByteString = type AnsiString;
/// pointer to a RawByteString
PRawByteString = ^RawByteString;
{$endif}
/// RawJSON will indicate that this variable content would stay in raw JSON
// - i.e. won't be serialized into values
// - could be any JSON content: number, string, object or array
// - e.g. interface-based service will use it for efficient and AJAX-ready
// transmission of TSQLTableJSON result
RawJSON = type RawUTF8;
/// SynUnicode is the fastest available Unicode native string type, depending
// on the compiler used
// - this type is native to the compiler, so you can use Length() Copy() and
// such functions with it (this is not possible with RawUnicodeString type)
// - before Delphi 2009+, it uses slow OLE compatible WideString
// (with our Enhanced RTL, WideString allocation can be made faster by using
// an internal caching mechanism of allocation buffers - WideString allocation
// has been made much faster since Windows Vista/Seven)
// - starting with Delphi 2009, it uses fastest UnicodeString type, which
// allow Copy On Write, Reference Counting and fast heap memory allocation
{$ifdef HASVARUSTRING}
SynUnicode = UnicodeString;
{$else}
SynUnicode = WideString;
{$endif HASVARUSTRING}
PRawUnicode = ^RawUnicode;
PRawJSON = ^RawJSON;
PRawUTF8 = ^RawUTF8;
PWinAnsiString = ^WinAnsiString;
PWinAnsiChar = type PAnsiChar;
PSynUnicode = ^SynUnicode;
/// a simple wrapper to UTF-8 encoded zero-terminated PAnsiChar
// - PAnsiChar is used only for Win-Ansi encoded text
// - the Synopse mORMot framework uses mostly this PUTF8Char type,
// because all data is internaly stored and expected to be UTF-8 encoded
PUTF8Char = type PAnsiChar;
PPUTF8Char = ^PUTF8Char;
/// a Row/Col array of PUTF8Char, for containing sqlite3_get_table() result
TPUtf8CharArray = array[0..MaxInt div SizeOf(PUTF8Char)-1] of PUTF8Char;
PPUtf8CharArray = ^TPUtf8CharArray;
/// a dynamic array of PUTF8Char pointers
TPUTF8CharDynArray = array of PUTF8Char;
/// a dynamic array of UTF-8 encoded strings
TRawUTF8DynArray = array of RawUTF8;
PRawUTF8DynArray = ^TRawUTF8DynArray;
TRawUTF8DynArrayDynArray = array of TRawUTF8DynArray;
/// a dynamic array of TVarRec, i.e. could match an "array of const" parameter
TTVarRecDynArray = array of TVarRec;
{$ifndef NOVARIANTS}
/// a TVarData values array
// - is not called TVarDataArray to avoid confusion with the corresponding
// type already defined in Variants.pas, and used for custom late-binding
TVarDataStaticArray = array[0..MaxInt div SizeOf(TVarData)-1] of TVarData;
PVarDataStaticArray = ^TVarDataStaticArray;
TVariantArray = array[0..MaxInt div SizeOf(Variant)-1] of Variant;
PVariantArray = ^TVariantArray;
TVariantDynArray = array of variant;
PPVariant = ^PVariant;
{$endif}
PIntegerDynArray = ^TIntegerDynArray;
TIntegerDynArray = array of integer;
TIntegerDynArrayDynArray = array of TIntegerDynArray;
PCardinalDynArray = ^TCardinalDynArray;
TCardinalDynArray = array of cardinal;
PSingleDynArray = ^TSingleDynArray;
TSingleDynArray = array of Single;
PInt64DynArray = ^TInt64DynArray;
TInt64DynArray = array of Int64;
PQwordDynArray = ^TQwordDynArray;
TQwordDynArray = array of Qword;
TPtrUIntDynArray = array of PtrUInt;
PDoubleDynArray = ^TDoubleDynArray;
TDoubleDynArray = array of double;
PCurrencyDynArray = ^TCurrencyDynArray;
TCurrencyDynArray = array of Currency;
TWordDynArray = array of word;
PWordDynArray = ^TWordDynArray;
TByteDynArray = array of byte;
PByteDynArray = ^TByteDynArray;
{$ifndef ISDELPHI2007ANDUP}
TBytes = array of byte;
{$endif}
TObjectDynArray = array of TObject;
PObjectDynArray = ^TObjectDynArray;
TPersistentDynArray = array of TPersistent;
PPersistentDynArray = ^TPersistentDynArray;
TPointerDynArray = array of pointer;
PPointerDynArray = ^TPointerDynArray;
TPPointerDynArray = array of PPointer;
PPPointerDynArray = ^TPPointerDynArray;
TMethodDynArray = array of TMethod;
PMethodDynArray = ^TMethodDynArray;
TObjectListDynArray = array of TObjectList;
PObjectListDynArray = ^TObjectListDynArray;
TFileNameDynArray = array of TFileName;
PFileNameDynArray = ^TFileNameDynArray;
TBooleanDynArray = array of boolean;
PBooleanDynArray = ^TBooleanDynArray;
TClassDynArray = array of TClass;
TWinAnsiDynArray = array of WinAnsiString;
PWinAnsiDynArray = ^TWinAnsiDynArray;
TRawByteStringDynArray = array of RawByteString;
TStringDynArray = array of string;
PStringDynArray = ^TStringDynArray;
PShortStringDynArray = array of PShortString;
PPShortStringArray = ^PShortStringArray;
TShortStringDynArray = array of ShortString;
TDateTimeDynArray = array of TDateTime;
PDateTimeDynArray = ^TDateTimeDynArray;
{$ifndef FPC_OR_UNICODE}
TDate = type TDateTime;
TTime = type TDateTime;
{$endif FPC_OR_UNICODE}
TDateDynArray = array of TDate;
PDateDynArray = ^TDateDynArray;
TTimeDynArray = array of TTime;
PTimeDynArray = ^TTimeDynArray;
TWideStringDynArray = array of WideString;
PWideStringDynArray = ^TWideStringDynArray;
TSynUnicodeDynArray = array of SynUnicode;
PSynUnicodeDynArray = ^TSynUnicodeDynArray;
TGUIDDynArray = array of TGUID;
PObject = ^TObject;
PClass = ^TClass;
PByteArray = ^TByteArray;
TByteArray = array[0..MaxInt-1] of Byte; // redefine here with {$R-}
PBooleanArray = ^TBooleanArray;
TBooleanArray = array[0..MaxInt-1] of Boolean;
TWordArray = array[0..MaxInt div SizeOf(word)-1] of word;
PWordArray = ^TWordArray;
TIntegerArray = array[0..MaxInt div SizeOf(integer)-1] of integer;
PIntegerArray = ^TIntegerArray;
PIntegerArrayDynArray = array of PIntegerArray;
TPIntegerArray = array[0..MaxInt div SizeOf(PIntegerArray)-1] of PInteger;
PPIntegerArray = ^TPIntegerArray;
TCardinalArray = array[0..MaxInt div SizeOf(cardinal)-1] of cardinal;
PCardinalArray = ^TCardinalArray;
TInt64Array = array[0..MaxInt div SizeOf(Int64)-1] of Int64;
PInt64Array = ^TInt64Array;
TQWordArray = array[0..MaxInt div SizeOf(QWord)-1] of QWord;
PQWordArray = ^TQWordArray;
TPtrUIntArray = array[0..MaxInt div SizeOf(PtrUInt)-1] of PtrUInt;
PPtrUIntArray = ^TPtrUIntArray;
TSmallIntArray = array[0..MaxInt div SizeOf(SmallInt)-1] of SmallInt;
PSmallIntArray = ^TSmallIntArray;
TSingleArray = array[0..MaxInt div SizeOf(Single)-1] of Single;
PSingleArray = ^TSingleArray;
TDoubleArray = array[0..MaxInt div SizeOf(Double)-1] of Double;
PDoubleArray = ^TDoubleArray;
TDateTimeArray = array[0..MaxInt div SizeOf(TDateTime)-1] of TDateTime;
PDateTimeArray = ^TDateTimeArray;
TPAnsiCharArray = array[0..MaxInt div SizeOf(PAnsiChar)-1] of PAnsiChar;
PPAnsiCharArray = ^TPAnsiCharArray;
TRawUTF8Array = array[0..MaxInt div SizeOf(RawUTF8)-1] of RawUTF8;
PRawUTF8Array = ^TRawUTF8Array;
TRawByteStringArray = array[0..MaxInt div SizeOf(RawByteString)-1] of RawByteString;
PRawByteStringArray = ^TRawByteStringArray;
PShortStringArray = array[0..MaxInt div SizeOf(pointer)-1] of PShortString;
PointerArray = array [0..MaxInt div SizeOf(Pointer)-1] of Pointer;
PPointerArray = ^PointerArray;
TObjectArray = array [0..MaxInt div SizeOf(TObject)-1] of TObject;
PObjectArray = ^TObjectArray;
TPtrIntArray = array[0..MaxInt div SizeOf(PtrInt)-1] of PtrInt;
PPtrIntArray = ^TPtrIntArray;
PInt64Rec = ^Int64Rec;
PPShortString = ^PShortString;
{$ifndef DELPHI5OROLDER}
PIInterface = ^IInterface;
TInterfaceDynArray = array of IInterface;
PInterfaceDynArray = ^TInterfaceDynArray;
{$endif}
{$ifndef LVCL}
TCollectionClass = class of TCollection;
TCollectionItemClass = class of TCollectionItem;
{$endif}
/// class-reference type (metaclass) of a TStream
TStreamClass = class of TStream;
/// class-reference type (metaclass) of a TInterfacedObject
TInterfacedObjectClass = class of TInterfacedObject;
{ ************ fast UTF-8 / Unicode / Ansi types and conversion routines **** }
// some constants used for UTF-8 conversion, including surrogates
const
UTF16_HISURROGATE_MIN = $d800;
UTF16_HISURROGATE_MAX = $dbff;
UTF16_LOSURROGATE_MIN = $dc00;
UTF16_LOSURROGATE_MAX = $dfff;
UTF8_EXTRABYTES: array[$80..$ff] of byte = (
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,4,4,4,4,5,5,0,0);
UTF8_EXTRA: array[0..6] of record
offset, minimum: cardinal;
end = ( // http://floodyberry.wordpress.com/2007/04/14/utf-8-conversion-tricks
(offset: $00000000; minimum: $00010000),
(offset: $00003080; minimum: $00000080),
(offset: $000e2080; minimum: $00000800),
(offset: $03c82080; minimum: $00010000),
(offset: $fa082080; minimum: $00200000),
(offset: $82082080; minimum: $04000000),
(offset: $00000000; minimum: $04000000));
UTF8_EXTRA_SURROGATE = 3;
UTF8_FIRSTBYTE: array[2..6] of byte = ($c0,$e0,$f0,$f8,$fc);
type
/// kind of adding in a TTextWriter
TTextWriterKind = (twNone, twJSONEscape, twOnSameLine);
/// an abstract class to handle Ansi to/from Unicode translation
// - implementations of this class will handle efficiently all Code Pages
// - this default implementation will use the Operating System APIs
// - you should not create your own class instance by yourself, but should
// better retrieve an instance using TSynAnsiConvert.Engine(), which will
// initialize either a TSynAnsiFixedWidth or a TSynAnsiConvert instance on need
TSynAnsiConvert = class
protected
fCodePage: cardinal;
fAnsiCharShift: byte;
{$ifdef KYLIX3}
fIConvCodeName: RawUTF8;
{$endif}
procedure InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal;
DestTextWriter: TObject; Escape: TTextWriterKind); virtual;
public
/// initialize the internal conversion engine
constructor Create(aCodePage: cardinal); reintroduce; virtual;
/// returns the engine corresponding to a given code page
// - a global list of TSynAnsiConvert instances is handled by the unit -
// therefore, caller should not release the returned instance
// - will return nil in case of unhandled code page
// - is aCodePage is 0, will return CurrentAnsiConvert value
class function Engine(aCodePage: cardinal): TSynAnsiConvert;
/// direct conversion of a PAnsiChar buffer into an Unicode buffer
// - Dest^ buffer must be reserved with at least SourceChars*2 bytes
// - this default implementation will use the Operating System APIs
// - will append a trailing #0 to the returned PWideChar, unless
// NoTrailingZero is set
function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar;
SourceChars: Cardinal; NoTrailingZero: boolean=false): PWideChar; overload; virtual;
/// direct conversion of a PAnsiChar buffer into a UTF-8 encoded buffer
// - Dest^ buffer must be reserved with at least SourceChars*3 bytes
// - will append a trailing #0 to the returned PUTF8Char, unless
// NoTrailingZero is set
// - this default implementation will use the Operating System APIs
function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar;
SourceChars: Cardinal; NoTrailingZero: boolean=false): PUTF8Char; overload; virtual;
/// convert any Ansi Text into an UTF-16 Unicode String
// - returns a value using our RawUnicode kind of string
function AnsiToRawUnicode(const AnsiText: RawByteString): RawUnicode; overload;
/// convert any Ansi buffer into an Unicode String
// - returns a value using our RawUnicode kind of string
function AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; overload; virtual;
/// convert any Ansi buffer into an Unicode String
// - returns a SynUnicode, i.e. Delphi 2009+ UnicodeString or a WideString
function AnsiToUnicodeString(Source: PAnsiChar; SourceChars: Cardinal): SynUnicode; overload;
/// convert any Ansi buffer into an Unicode String
// - returns a SynUnicode, i.e. Delphi 2009+ UnicodeString or a WideString
function AnsiToUnicodeString(const Source: RawByteString): SynUnicode; overload;
/// convert any Ansi Text into an UTF-8 encoded String
// - internaly calls AnsiBufferToUTF8 virtual method
function AnsiToUTF8(const AnsiText: RawByteString): RawUTF8; virtual;
/// direct conversion of a PAnsiChar buffer into a UTF-8 encoded string
// - will call AnsiBufferToUnicode() overloaded virtual method
function AnsiBufferToRawUTF8(Source: PAnsiChar; SourceChars: Cardinal): RawUTF8; overload; virtual;
/// direct conversion of an Unicode buffer into a PAnsiChar buffer
// - Dest^ buffer must be reserved with at least SourceChars*3 bytes
// - this default implementation will rely on the Operating System for
// all non ASCII-7 chars
function UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; overload; virtual;
/// direct conversion of an Unicode buffer into an Ansi Text
function UnicodeBufferToAnsi(Source: PWideChar; SourceChars: Cardinal): RawByteString; overload; virtual;
/// convert any Unicode-encoded String into Ansi Text
// - internaly calls UnicodeBufferToAnsi virtual method
function RawUnicodeToAnsi(const Source: RawUnicode): RawByteString;
/// direct conversion of an UTF-8 encoded buffer into a PAnsiChar buffer
// - Dest^ buffer must be reserved with at least SourceChars bytes
// - no trailing #0 is appended to the buffer
function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char;
SourceChars: Cardinal): PAnsiChar; overload; virtual;
/// convert any UTF-8 encoded buffer into Ansi Text
// - internaly calls UTF8BufferToAnsi virtual method
function UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal): RawByteString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert any UTF-8 encoded buffer into Ansi Text
// - internaly calls UTF8BufferToAnsi virtual method
procedure UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal;
var result: RawByteString); overload; virtual;
/// convert any UTF-8 encoded String into Ansi Text
// - internaly calls UTF8BufferToAnsi virtual method
function UTF8ToAnsi(const UTF8: RawUTF8): RawByteString; virtual;
/// direct conversion of a UTF-8 encoded string into a WinAnsi buffer
// - will truncate the destination string to DestSize bytes (including the
// trailing #0), with a maximum handled size of 2048 bytes
// - returns the number of bytes stored in Dest^ (i.e. the position of #0)
function Utf8ToAnsiBuffer(const S: RawUTF8; Dest: PAnsiChar; DestSize: integer): integer;
/// convert any Ansi Text (providing a From converted) into Ansi Text
function AnsiToAnsi(From: TSynAnsiConvert; const Source: RawByteString): RawByteString; overload;
/// convert any Ansi buffer (providing a From converted) into Ansi Text
function AnsiToAnsi(From: TSynAnsiConvert; Source: PAnsiChar; SourceChars: cardinal): RawByteString; overload;
/// corresponding code page
property CodePage: Cardinal read fCodePage;
end;
/// a class to handle Ansi to/from Unicode translation of fixed width encoding
// (i.e. non MBCS)
// - this class will handle efficiently all Code Page availables without MBCS
// encoding - like WinAnsi (1252) or Russian (1251)
// - it will use internal fast look-up tables for such encodings
// - this class could take some time to generate, and will consume more than
// 64 KB of memory: you should not create your own class instance by yourself,
// but should better retrieve an instance using TSynAnsiConvert.Engine(), which
// will initialize either a TSynAnsiFixedWidth or a TSynAnsiConvert instance
// on need
// - this class has some additional methods (e.g. IsValid*) which take
// advantage of the internal lookup tables to provide some fast process
TSynAnsiFixedWidth = class(TSynAnsiConvert)
protected
fAnsiToWide: TWordDynArray;
fWideToAnsi: TByteDynArray;
procedure InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal;
DestTextWriter: TObject; Escape: TTextWriterKind); override;
public
/// initialize the internal conversion engine
constructor Create(aCodePage: cardinal); override;
/// direct conversion of a PAnsiChar buffer into an Unicode buffer
// - Dest^ buffer must be reserved with at least SourceChars*2 bytes
// - will append a trailing #0 to the returned PWideChar, unless
// NoTrailingZero is set
function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar;
SourceChars: Cardinal; NoTrailingZero: boolean=false): PWideChar; override;
/// direct conversion of a PAnsiChar buffer into a UTF-8 encoded buffer
// - Dest^ buffer must be reserved with at least SourceChars*3 bytes
// - will append a trailing #0 to the returned PUTF8Char, unless
// NoTrailingZero is set
function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar;
SourceChars: Cardinal; NoTrailingZero: boolean=false): PUTF8Char; override;
/// convert any Ansi buffer into an Unicode String
// - returns a value using our RawUnicode kind of string
function AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; override;
/// direct conversion of an Unicode buffer into a PAnsiChar buffer
// - Dest^ buffer must be reserved with at least SourceChars*3 bytes
// - this overridden version will use internal lookup tables for fast process
function UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; override;
/// direct conversion of an UTF-8 encoded buffer into a PAnsiChar buffer
// - Dest^ buffer must be reserved with at least SourceChars bytes
// - no trailing #0 is appended to the buffer
function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char;
SourceChars: Cardinal): PAnsiChar; override;
/// conversion of a wide char into the corresponding Ansi character
// - return -1 for an unknown WideChar in the current code page
function WideCharToAnsiChar(wc: cardinal): integer;
/// return TRUE if the supplied unicode buffer only contains characters of
// the corresponding Ansi code page
// - i.e. if the text can be displayed using this code page
function IsValidAnsi(WideText: PWideChar; Length: PtrInt): boolean; overload;
/// return TRUE if the supplied unicode buffer only contains characters of
// the corresponding Ansi code page
// - i.e. if the text can be displayed using this code page
function IsValidAnsi(WideText: PWideChar): boolean; overload;
/// return TRUE if the supplied UTF-8 buffer only contains characters of
// the corresponding Ansi code page
// - i.e. if the text can be displayed using this code page
function IsValidAnsiU(UTF8Text: PUTF8Char): boolean;
/// return TRUE if the supplied UTF-8 buffer only contains 8 bits characters
// of the corresponding Ansi code page
// - i.e. if the text can be displayed with only 8 bit unicode characters
// (e.g. no "tm" or such) within this code page
function IsValidAnsiU8Bit(UTF8Text: PUTF8Char): boolean;
/// direct access to the Ansi-To-Unicode lookup table
// - use this array like AnsiToWide: array[byte] of word
property AnsiToWide: TWordDynArray read fAnsiToWide;
/// direct access to the Unicode-To-Ansi lookup table
// - use this array like WideToAnsi: array[word] of byte
// - any unhandled WideChar will return ord('?')
property WideToAnsi: TByteDynArray read fWideToAnsi;
end;
/// a class to handle UTF-8 to/from Unicode translation
// - match the TSynAnsiConvert signature, for code page CP_UTF8
// - this class is mostly a non-operation for conversion to/from UTF-8
TSynAnsiUTF8 = class(TSynAnsiConvert)
private
function UnicodeBufferToUTF8(Dest: PAnsiChar; DestChars: Cardinal;
Source: PWideChar; SourceChars: Cardinal): PAnsiChar;
protected
procedure InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal;
DestTextWriter: TObject; Escape: TTextWriterKind); override;
public
/// initialize the internal conversion engine
constructor Create(aCodePage: cardinal); override;
/// direct conversion of a PAnsiChar UTF-8 buffer into an Unicode buffer
// - Dest^ buffer must be reserved with at least SourceChars*2 bytes
// - will append a trailing #0 to the returned PWideChar, unless
// NoTrailingZero is set
function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar;
SourceChars: Cardinal; NoTrailingZero: boolean=false): PWideChar; override;
/// direct conversion of a PAnsiChar UTF-8 buffer into a UTF-8 encoded buffer
// - Dest^ buffer must be reserved with at least SourceChars*3 bytes
// - will append a trailing #0 to the returned PUTF8Char, unless
// NoTrailingZero is set
function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar;
SourceChars: Cardinal; NoTrailingZero: boolean=false): PUTF8Char; override;
/// convert any UTF-8 Ansi buffer into an Unicode String
// - returns a value using our RawUnicode kind of string
function AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; override;
/// direct conversion of an Unicode buffer into a PAnsiChar UTF-8 buffer
// - Dest^ buffer must be reserved with at least SourceChars*3 bytes
function UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; override;
/// direct conversion of an Unicode buffer into an Ansi Text
function UnicodeBufferToAnsi(Source: PWideChar; SourceChars: Cardinal): RawByteString; override;
/// direct conversion of an UTF-8 encoded buffer into a PAnsiChar UTF-8 buffer
// - Dest^ buffer must be reserved with at least SourceChars bytes
// - no trailing #0 is appended to the buffer
function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char;
SourceChars: Cardinal): PAnsiChar; override;
/// convert any UTF-8 encoded buffer into Ansi Text
procedure UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal;
var result: RawByteString); override;
/// convert any UTF-8 encoded String into Ansi Text
// - directly assign the input as result, since no conversion is needed
function UTF8ToAnsi(const UTF8: RawUTF8): RawByteString; override;
/// convert any Ansi Text into an UTF-8 encoded String
// - directly assign the input as result, since no conversion is needed
function AnsiToUTF8(const AnsiText: RawByteString): RawUTF8; override;
/// direct conversion of a PAnsiChar buffer into a UTF-8 encoded string
function AnsiBufferToRawUTF8(Source: PAnsiChar; SourceChars: Cardinal): RawUTF8; override;
end;
/// a class to handle UTF-16 to/from Unicode translation
// - match the TSynAnsiConvert signature, for code page CP_UTF16
// - even if UTF-16 is not an Ansi format, code page CP_UTF16 may have been
// used to store UTF-16 encoded binary content
// - this class is mostly a non-operation for conversion to/from Unicode
TSynAnsiUTF16 = class(TSynAnsiConvert)
public
/// initialize the internal conversion engine
constructor Create(aCodePage: cardinal); override;
/// direct conversion of a PAnsiChar UTF-16 buffer into an Unicode buffer
// - Dest^ buffer must be reserved with at least SourceChars*2 bytes
// - will append a trailing #0 to the returned PWideChar, unless
// NoTrailingZero is set
function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar;
SourceChars: Cardinal; NoTrailingZero: boolean=false): PWideChar; override;
/// direct conversion of a PAnsiChar UTF-16 buffer into a UTF-8 encoded buffer
// - Dest^ buffer must be reserved with at least SourceChars*3 bytes
// - will append a trailing #0 to the returned PUTF8Char, unless
// NoTrailingZero is set
function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar;
SourceChars: Cardinal; NoTrailingZero: boolean=false): PUTF8Char; override;
/// convert any UTF-16 Ansi buffer into an Unicode String
// - returns a value using our RawUnicode kind of string
function AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; override;
/// direct conversion of an Unicode buffer into a PAnsiChar UTF-16 buffer
// - Dest^ buffer must be reserved with at least SourceChars*3 bytes
function UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; override;
/// direct conversion of an UTF-8 encoded buffer into a PAnsiChar UTF-16 buffer
// - Dest^ buffer must be reserved with at least SourceChars bytes
// - no trailing #0 is appended to the buffer
function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char;
SourceChars: Cardinal): PAnsiChar; override;
end;
/// implements a stack-based storage of some (UTF-8 or binary) text
// - avoid temporary memory allocation via the heap for up to 4KB of data
// - could be used e.g. to make a temporary copy when JSON is parsed in-place
// - call one of the Init() overloaded methods, then Done to release its memory
// - all Init() methods will allocate 16 more bytes, for a trailing #0 and
// to ensure our fast JSON parsing won't trigger any GPF (since it may read
// up to 4 bytes ahead via its PInteger() trick) or any SSE4.2 function
{$ifdef USERECORDWITHMETHODS}TSynTempBuffer = record
{$else}TSynTempBuffer = object{$endif}
public
/// the text/binary length, in bytes, excluding the trailing #0
len: PtrInt;
/// where the text/binary is available (and any Source has been copied)
// - equals nil if len=0
buf: pointer;
/// initialize a temporary copy of the content supplied as RawByteString
// - will also allocate and copy the ending #0 (even for binary)
procedure Init(const Source: RawByteString); overload;
/// initialize a temporary copy of the supplied text buffer, ending with #0
function Init(Source: PUTF8Char): PUTF8Char; overload;
/// initialize a temporary copy of the supplied text buffer
procedure Init(Source: pointer; SourceLen: PtrInt); overload;
/// initialize a new temporary buffer of a given number of bytes
function Init(SourceLen: PtrInt): pointer; overload;
/// initialize a temporary buffer with the length of the internal stack
function InitOnStack: pointer;
/// initialize the buffer returning the internal buffer size (4095 bytes)
// - could be used e.g. for an API call, first trying with plain temp.Init
// and using temp.buf and temp.len safely in the call, only calling
// temp.Init(expectedsize) if the API returned an error about an insufficient
// buffer space
function Init: integer; overload; {$ifdef HASINLINE}inline;{$endif}
/// initialize a new temporary buffer of a given number of random bytes
// - will fill the buffer via FillRandom() calls
// - forcegsl is true by default, since Lecuyer's generator has no HW bug
function InitRandom(RandomLen: integer; forcegsl: boolean=true): pointer;
/// initialize a new temporary buffer filled with 32-bit integer increasing values
function InitIncreasing(Count: PtrInt; Start: PtrInt=0): PIntegerArray;
/// initialize a new temporary buffer of a given number of zero bytes
function InitZero(ZeroLen: PtrInt): pointer;
/// finalize the temporary storage
procedure Done; overload; {$ifdef HASINLINE}inline;{$endif}
/// finalize the temporary storage, and create a RawUTF8 string from it
procedure Done(EndBuf: pointer; var Dest: RawUTF8); overload;
private
// default 4KB buffer allocated on stack - after the len/buf main fields
tmp: array[0..4095] of AnsiChar;
end;
/// function prototype to be used for hashing of an element
// - it must return a cardinal hash, with as less collision as possible
// - TDynArrayHashed.Init will use crc32c() if no custom function is supplied,
// which will run either as software or SSE4.2 hardware, with good colision
// for most used kind of data
THasher = function(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
var
/// global TSynAnsiConvert instance to handle WinAnsi encoding (code page 1252)
// - this instance is global and instantied during the whole program life time
// - it will be created from hard-coded values, and not using the system API,
// since it appeared that some systems (e.g. in Russia) did tweak the registry
// so that 1252 code page maps 1251 code page
WinAnsiConvert: TSynAnsiFixedWidth;
/// global TSynAnsiConvert instance to handle current system encoding
// - this is the encoding as used by the AnsiString Delphi, so will be used
// before Delphi 2009 to speed-up VCL string handling (especially for UTF-8)
// - this instance is global and instantied during the whole program life time
CurrentAnsiConvert: TSynAnsiConvert;
/// global TSynAnsiConvert instance to handle UTF-8 encoding (code page CP_UTF8)
// - this instance is global and instantied during the whole program life time
UTF8AnsiConvert: TSynAnsiUTF8;
/// check if a codepage should be handled by a TSynAnsiFixedWidth page
function IsFixedWidthCodePage(aCodePage: cardinal): boolean;
{$ifdef HASINLINE}inline;{$endif}
const
/// HTTP header name for the content type, as defined in the corresponding RFC
HEADER_CONTENT_TYPE = 'Content-Type: ';
/// HTTP header name for the content type, in upper case
// - as defined in the corresponding RFC
// - could be used e.g. with IdemPChar() to retrieve the Content-Type value
HEADER_CONTENT_TYPE_UPPER = 'CONTENT-TYPE: ';
/// HTTP header name for the client IP, in upper case
// - as defined in our HTTP server classes
// - could be used e.g. with IdemPChar() to retrieve the remote IP address
HEADER_REMOTEIP_UPPER = 'REMOTEIP: ';
/// HTTP header name for the authorization token, in upper case
// - could be used e.g. with IdemPChar() to retrieve a JWT value
// - will detect header computed e.g. by SynCrtSock.AuthorizationBearer()
HEADER_BEARER_UPPER = 'AUTHORIZATION: BEARER ';
/// MIME content type used for JSON communication (as used by the Microsoft
// WCF framework and the YUI framework)
JSON_CONTENT_TYPE = 'application/json; charset=UTF-8';
/// HTTP header for MIME content type used for plain JSON
JSON_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+JSON_CONTENT_TYPE;
/// MIME content type used for plain JSON, in upper case
// - could be used e.g. with IdemPChar() to retrieve the Content-Type value
JSON_CONTENT_TYPE_UPPER = 'APPLICATION/JSON';
/// HTTP header for MIME content type used for plain JSON, in upper case
// - could be used e.g. with IdemPChar() to retrieve the Content-Type value
JSON_CONTENT_TYPE_HEADER_UPPER = HEADER_CONTENT_TYPE_UPPER+JSON_CONTENT_TYPE_UPPER;
/// MIME content type used for plain UTF-8 text
TEXT_CONTENT_TYPE = 'text/plain; charset=UTF-8';
/// HTTP header for MIME content type used for plain UTF-8 text
TEXT_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+TEXT_CONTENT_TYPE;
/// MIME content type used for UTF-8 encoded HTML
HTML_CONTENT_TYPE = 'text/html; charset=UTF-8';
/// HTTP header for MIME content type used for UTF-8 encoded HTML
HTML_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+HTML_CONTENT_TYPE;
/// MIME content type used for UTF-8 encoded XML
XML_CONTENT_TYPE = 'text/xml; charset=UTF-8';
/// HTTP header for MIME content type used for UTF-8 encoded XML
XML_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+XML_CONTENT_TYPE;
/// MIME content type used for raw binary data
BINARY_CONTENT_TYPE = 'application/octet-stream';
/// MIME content type used for raw binary data, in upper case
BINARY_CONTENT_TYPE_UPPER = 'APPLICATION/OCTET-STREAM';
/// HTTP header for MIME content type used for raw binary data
BINARY_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+BINARY_CONTENT_TYPE;
/// MIME content type used for a JPEG picture
JPEG_CONTENT_TYPE = 'image/jpeg';
var
/// MIME content type used for JSON communication
// - i.e. 'application/json; charset=UTF-8'
// - this global will be initialized with JSON_CONTENT_TYPE constant, to
// avoid a memory allocation each time it is assigned to a variable
JSON_CONTENT_TYPE_VAR: RawUTF8;
/// HTTP header for MIME content type used for plain JSON
// - this global will be initialized with JSON_CONTENT_TYPE_HEADER constant,
// to avoid a memory allocation each time it is assigned to a variable
JSON_CONTENT_TYPE_HEADER_VAR: RawUTF8;
/// can be used to avoid a memory allocation for res := 'null'
NULL_STR_VAR: RawUTF8;
/// compute the new capacity when expanding an array of items
// - handle tiny, small, medium, large and huge sizes properly to reduce
// memory usage and maximize performance
function NextGrow(capacity: integer): integer;
/// equivalence to SetString(s,nil,len) function
// - faster especially under FPC
procedure FastSetString(var s: RawUTF8; p: pointer; len: PtrInt);
{$ifndef HASCODEPAGE}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// equivalence to SetString(s,nil,len) function with a specific code page
// - faster especially under FPC
procedure FastSetStringCP(var s; p: pointer; len, codepage: PtrInt);
{$ifndef HASCODEPAGE}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// initialize a RawByteString, ensuring returned "aligned" pointer is 16-bytes aligned
// - to be used e.g. for proper SSE process
procedure GetMemAligned(var s: RawByteString; p: pointer; len: PtrInt;
out aligned: pointer);
/// equivalence to @UTF8[1] expression to ensure a RawUTF8 variable is unique
// - will ensure that the string refcount is 1, and return a pointer to the text
// - under FPC, @UTF8[1] does not call UniqueString() as it does with Delphi
// - if UTF8 is a constant (refcount=-1), will create a temporary copy in heap
function UniqueRawUTF8(var UTF8: RawUTF8): pointer;
{$ifdef HASINLINE}inline;{$endif}
/// will fast replace all #0 chars as ~
// - could be used after UniqueRawUTF8() on a in-placed modified JSON buffer,
// in which all values have been ended with #0
// - you can optionally specify a maximum size, in bytes (this won't reallocate
// the string, but just add a #0 at some point in the UTF8 buffer)
// - could allow logging of parsed input e.g. after an exception
procedure UniqueRawUTF8ZeroToTilde(var UTF8: RawUTF8; MaxSize: integer=maxInt);
/// conversion of a wide char into a WinAnsi (CodePage 1252) char
// - return '?' for an unknown WideChar in code page 1252
function WideCharToWinAnsiChar(wc: cardinal): AnsiChar;
{$ifdef HASINLINE}inline;{$endif}
/// conversion of a wide char into a WinAnsi (CodePage 1252) char index
// - return -1 for an unknown WideChar in code page 1252
function WideCharToWinAnsi(wc: cardinal): integer;
{$ifdef HASINLINE}inline;{$endif}
/// return TRUE if the supplied buffer only contains 7-bits Ansi characters
function IsAnsiCompatible(PC: PAnsiChar): boolean; overload;
/// return TRUE if the supplied UTF-16 buffer only contains 7-bits Ansi characters
function IsAnsiCompatibleW(PW: PWideChar): boolean; overload;
/// return TRUE if the supplied buffer only contains 7-bits Ansi characters
function IsAnsiCompatible(PC: PAnsiChar; Len: PtrUInt): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// return TRUE if the supplied text only contains 7-bits Ansi characters
function IsAnsiCompatible(const Text: RawByteString): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// return TRUE if the supplied UTF-16 buffer only contains 7-bits Ansi characters
function IsAnsiCompatibleW(PW: PWideChar; Len: PtrInt): boolean; overload;
/// return TRUE if the supplied unicode buffer only contains WinAnsi characters
// - i.e. if the text can be displayed using ANSI_CHARSET
function IsWinAnsi(WideText: PWideChar): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// return TRUE if the supplied unicode buffer only contains WinAnsi characters
// - i.e. if the text can be displayed using ANSI_CHARSET
function IsWinAnsi(WideText: PWideChar; Length: integer): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// return TRUE if the supplied UTF-8 buffer only contains WinAnsi characters
// - i.e. if the text can be displayed using ANSI_CHARSET
function IsWinAnsiU(UTF8Text: PUTF8Char): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// return TRUE if the supplied UTF-8 buffer only contains WinAnsi 8 bit characters
// - i.e. if the text can be displayed using ANSI_CHARSET with only 8 bit unicode
// characters (e.g. no "tm" or such)
function IsWinAnsiU8Bit(UTF8Text: PUTF8Char): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// UTF-8 encode one UTF-16 character into Dest
// - return the number of bytes written into Dest (i.e. 1,2 or 3)
// - this method does NOT handle UTF-16 surrogate pairs
function WideCharToUtf8(Dest: PUTF8Char; aWideChar: PtrUInt): integer;
{$ifdef HASINLINE}inline;{$endif}
/// UTF-8 encode one UTF-16 encoded UCS4 character into Dest
// - return the number of bytes written into Dest (i.e. from 1 up to 6)
// - Source will contain the next UTF-16 character
// - this method DOES handle UTF-16 surrogate pairs
function UTF16CharToUtf8(Dest: PUTF8Char; var Source: PWord): integer;
/// UTF-8 encode one UCS4 character into Dest
// - return the number of bytes written into Dest (i.e. from 1 up to 6)
// - this method DOES handle UTF-16 surrogate pairs
function UCS4ToUTF8(ucs4: cardinal; Dest: PUTF8Char): integer;
/// direct conversion of an AnsiString with an unknown code page into an
// UTF-8 encoded String
// - will assume CurrentAnsiConvert.CodePage prior to Delphi 2009
// - newer UNICODE versions of Delphi will retrieve the code page from string
procedure AnyAnsiToUTF8(const s: RawByteString; var result: RawUTF8); overload;
/// direct conversion of an AnsiString with an unknown code page into an
// UTF-8 encoded String
// - will assume CurrentAnsiConvert.CodePage prior to Delphi 2009
// - newer UNICODE versions of Delphi will retrieve the code page from string
function AnyAnsiToUTF8(const s: RawByteString): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// direct conversion of a WinAnsi (CodePage 1252) string into a UTF-8 encoded String
// - faster than SysUtils: don't use Utf8Encode(WideString) -> no Windows.Global(),
// and use a fixed pre-calculated array for individual chars conversion
function WinAnsiToUtf8(const S: WinAnsiString): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// direct conversion of a WinAnsi (CodePage 1252) string into a UTF-8 encoded String
// - faster than SysUtils: don't use Utf8Encode(WideString) -> no Windows.Global(),
// and use a fixed pre-calculated array for individual chars conversion
function WinAnsiToUtf8(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// direct conversion of a WinAnsi PAnsiChar buffer into a UTF-8 encoded buffer
// - Dest^ buffer must be reserved with at least SourceChars*3
// - call internally WinAnsiConvert fast conversion class
function WinAnsiBufferToUtf8(Dest: PUTF8Char; Source: PAnsiChar; SourceChars: Cardinal): PUTF8Char;
{$ifdef HASINLINE}inline;{$endif}
/// direct conversion of a WinAnsi shortstring into a UTF-8 text
// - call internally WinAnsiConvert fast conversion class
function ShortStringToUTF8(const source: ShortString): RawUTF8;
{$ifdef HASINLINE}inline;{$endif}
/// direct conversion of a WinAnsi (CodePage 1252) string into a Unicode encoded String
// - very fast, by using a fixed pre-calculated array for individual chars conversion
function WinAnsiToRawUnicode(const S: WinAnsiString): RawUnicode;
/// direct conversion of a WinAnsi (CodePage 1252) string into a Unicode buffer
// - very fast, by using a fixed pre-calculated array for individual chars conversion
// - text will be truncated if necessary to avoid buffer overflow in Dest[]
procedure WinAnsiToUnicodeBuffer(const S: WinAnsiString; Dest: PWordArray; DestLen: PtrInt);
{$ifdef HASINLINE}inline;{$endif}
/// direct conversion of a UTF-8 encoded string into a WinAnsi String
function Utf8ToWinAnsi(const S: RawUTF8): WinAnsiString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// direct conversion of a UTF-8 encoded zero terminated buffer into a WinAnsi String
function Utf8ToWinAnsi(P: PUTF8Char): WinAnsiString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// direct conversion of a UTF-8 encoded zero terminated buffer into a RawUTF8 String
procedure Utf8ToRawUTF8(P: PUTF8Char; var result: RawUTF8);
{$ifdef HASINLINE}inline;{$endif}
/// direct conversion of a UTF-8 encoded buffer into a WinAnsi PAnsiChar buffer
function UTF8ToWinPChar(dest: PAnsiChar; source: PUTF8Char; count: integer): integer;
{$ifdef HASINLINE}inline;{$endif}
/// direct conversion of a UTF-8 encoded buffer into a WinAnsi shortstring buffer
procedure UTF8ToShortString(var dest: shortstring; source: PUTF8Char);
/// direct conversion of an ANSI-7 shortstring into an AnsiString
// - can be used e.g. for names retrieved from RTTI to convert them into RawUTF8
function ShortStringToAnsi7String(const source: shortstring): RawByteString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// direct conversion of an ANSI-7 shortstring into an AnsiString
// - can be used e.g. for names retrieved from RTTI to convert them into RawUTF8
procedure ShortStringToAnsi7String(const source: shortstring; var result: RawUTF8); overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert an UTF-8 encoded text into a WideChar (UTF-16) buffer
// - faster than System.UTF8ToUnicode
// - sourceBytes can by 0, therefore length is computed from zero terminated source
// - enough place must be available in dest buffer (guess is sourceBytes*3+2)
// - a WideChar(#0) is added at the end (if something is written) unless
// NoTrailingZero is TRUE
// - returns the BYTE count written in dest, excluding the ending WideChar(#0)
function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; sourceBytes: PtrInt=0;
NoTrailingZero: boolean=false): PtrInt; overload;
/// convert an UTF-8 encoded text into a WideChar (UTF-16) buffer
// - faster than System.UTF8ToUnicode
// - this overloaded function expect a MaxDestChars parameter
// - sourceBytes can not be 0 for this function
// - enough place must be available in dest buffer (guess is sourceBytes*3+2)
// - a WideChar(#0) is added at the end (if something is written) unless
// NoTrailingZero is TRUE
// - returns the BYTE COUNT (not WideChar count) written in dest, excluding the
// ending WideChar(#0)
function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char;
MaxDestChars, sourceBytes: PtrInt; NoTrailingZero: boolean=false): PtrInt; overload;
/// calculate the UTF-16 Unicode characters count, UTF-8 encoded in source^
// - count may not match the UCS4 glyphs number, in case of UTF-16 surrogates
// - faster than System.UTF8ToUnicode with dest=nil
function Utf8ToUnicodeLength(source: PUTF8Char): PtrUInt;
/// returns TRUE if the supplied buffer has valid UTF-8 encoding with no #1..#31
// control characters
// - supplied input is a pointer to a #0 ended text buffer
function IsValidUTF8WithoutControlChars(source: PUTF8Char): Boolean; overload;
/// returns TRUE if the supplied buffer has valid UTF-8 encoding with no #0..#31
// control characters
// - supplied input is a RawUTF8 variable
function IsValidUTF8WithoutControlChars(const source: RawUTF8): Boolean; overload;
/// will truncate the supplied UTF-8 value if its length exceeds the specified
// UTF-16 Unicode characters count
// - count may not match the UCS4 glyphs number, in case of UTF-16 surrogates
// - returns FALSE if text was not truncated, TRUE otherwise
function Utf8TruncateToUnicodeLength(var text: RawUTF8; maxUtf16: integer): boolean;
/// will truncate the supplied UTF-8 value if its length exceeds the specified
// bytes count
// - this function will ensure that the returned content will contain only valid
// UTF-8 sequence, i.e. will trim the whole trailing UTF-8 sequence
// - returns FALSE if text was not truncated, TRUE otherwise
function Utf8TruncateToLength(var text: RawUTF8; maxBytes: PtrUInt): boolean;
/// compute the truncated length of the supplied UTF-8 value if it exceeds the
// specified bytes count
// - this function will ensure that the returned content will contain only valid
// UTF-8 sequence, i.e. will trim the whole trailing UTF-8 sequence
// - returns maxUTF8 if text was not truncated, or the number of fitting bytes
function Utf8TruncatedLength(const text: RawUTF8; maxBytes: PtrUInt): PtrInt; overload;
/// compute the truncated length of the supplied UTF-8 value if it exceeds the
// specified bytes count
// - this function will ensure that the returned content will contain only valid
// UTF-8 sequence, i.e. will trim the whole trailing UTF-8 sequence
// - returns maxUTF8 if text was not truncated, or the number of fitting bytes
function Utf8TruncatedLength(text: PAnsiChar; textlen,maxBytes: PtrUInt): PtrInt; overload;
/// calculate the UTF-16 Unicode characters count of the UTF-8 encoded first line
// - count may not match the UCS4 glyphs number, in case of UTF-16 surrogates
// - end the parsing at first #13 or #10 character
function Utf8FirstLineToUnicodeLength(source: PUTF8Char): PtrInt;
/// convert a UTF-8 encoded buffer into a RawUnicode string
// - if L is 0, L is computed from zero terminated P buffer
// - RawUnicode is ended by a WideChar(#0)
// - faster than System.Utf8Decode() which uses slow widestrings
function Utf8DecodeToRawUnicode(P: PUTF8Char; L: integer): RawUnicode; overload;
/// convert a UTF-8 string into a RawUnicode string
function Utf8DecodeToRawUnicode(const S: RawUTF8): RawUnicode; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert a UTF-8 string into a RawUnicode string
// - this version doesn't resize the length of the result RawUnicode
// and is therefore useful before a Win32 Unicode API call (with nCount=-1)
// - if DestLen is not nil, the resulting length (in bytes) will be stored within
function Utf8DecodeToRawUnicodeUI(const S: RawUTF8; DestLen: PInteger=nil): RawUnicode; overload;
/// convert a UTF-8 string into a RawUnicode string
// - returns the resulting length (in bytes) will be stored within Dest
function Utf8DecodeToRawUnicodeUI(const S: RawUTF8; var Dest: RawUnicode): integer; overload;
type
/// option set for RawUnicodeToUtf8() conversion
TCharConversionFlags = set of (
ccfNoTrailingZero, ccfReplacementCharacterForUnmatchedSurrogate);
/// convert a RawUnicode PWideChar into a UTF-8 string
procedure RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer;
var result: RawUTF8; Flags: TCharConversionFlags = [ccfNoTrailingZero]); overload;
/// convert a RawUnicode PWideChar into a UTF-8 string
function RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer;
Flags: TCharConversionFlags = [ccfNoTrailingZero]): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert a RawUnicode UTF-16 PWideChar into a UTF-8 buffer
// - replace system.UnicodeToUtf8 implementation, which is rather slow
// since Delphi 2009+
// - append a trailing #0 to the ending PUTF8Char, unless ccfNoTrailingZero is set
// - if ccfReplacementCharacterForUnmatchedSurrogate is set, this function will identify
// unmatched surrogate pairs and replace them with EF BF BD / FFFD Unicode
// Replacement character - see https://en.wikipedia.org/wiki/Specials_(Unicode_block)
function RawUnicodeToUtf8(Dest: PUTF8Char; DestLen: PtrInt;
Source: PWideChar; SourceLen: PtrInt; Flags: TCharConversionFlags): PtrInt; overload;
/// convert a RawUnicode PWideChar into a UTF-8 string
// - this version doesn't resize the resulting RawUTF8 string, but return
// the new resulting RawUTF8 byte count into UTF8Length
function RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer;
out UTF8Length: integer): RawUTF8; overload;
/// convert a RawUnicode string into a UTF-8 string
function RawUnicodeToUtf8(const Unicode: RawUnicode): RawUTF8; overload;
/// convert a SynUnicode string into a UTF-8 string
function SynUnicodeToUtf8(const Unicode: SynUnicode): RawUTF8;
/// convert a WideString into a UTF-8 string
function WideStringToUTF8(const aText: WideString): RawUTF8;
{$ifdef HASINLINE}inline;{$endif}
/// direct conversion of a Unicode encoded buffer into a WinAnsi PAnsiChar buffer
procedure RawUnicodeToWinPChar(dest: PAnsiChar; source: PWideChar; WideCharCount: integer);
{$ifdef HASINLINE}inline;{$endif}
/// convert a RawUnicode PWideChar into a WinAnsi (code page 1252) string
function RawUnicodeToWinAnsi(WideChar: PWideChar; WideCharCount: integer): WinAnsiString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert a RawUnicode string into a WinAnsi (code page 1252) string
function RawUnicodeToWinAnsi(const Unicode: RawUnicode): WinAnsiString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert a WideString into a WinAnsi (code page 1252) string
function WideStringToWinAnsi(const Wide: WideString): WinAnsiString;
{$ifdef HASINLINE}inline;{$endif}
/// convert an AnsiChar buffer (of a given code page) into a UTF-8 string
procedure AnsiCharToUTF8(P: PAnsiChar; L: Integer; var result: RawUTF8; ACP: integer);
/// convert any Raw Unicode encoded String into a generic SynUnicode Text
function RawUnicodeToSynUnicode(const Unicode: RawUnicode): SynUnicode; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert any Raw Unicode encoded String into a generic SynUnicode Text
function RawUnicodeToSynUnicode(WideChar: PWideChar; WideCharCount: integer): SynUnicode; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert an Unicode buffer into a WinAnsi (code page 1252) string
procedure UnicodeBufferToWinAnsi(source: PWideChar; out Dest: WinAnsiString);
/// convert an Unicode buffer into a generic VCL string
function UnicodeBufferToString(source: PWideChar): string;
{$ifdef HASVARUSTRING}
/// convert a Delphi 2009+ or FPC Unicode string into our UTF-8 string
function UnicodeStringToUtf8(const S: UnicodeString): RawUTF8; inline;
// this function is the same as direct RawUTF8=AnsiString(CP_UTF8) assignment
// but is faster, since it uses no Win32 API call
function UTF8DecodeToUnicodeString(const S: RawUTF8): UnicodeString; overload; inline;
/// convert our UTF-8 encoded buffer into a Delphi 2009+ Unicode string
// - this function is the same as direct assignment, since RawUTF8=AnsiString(CP_UTF8),
// but is faster, since use no Win32 API call
procedure UTF8DecodeToUnicodeString(P: PUTF8Char; L: integer; var result: UnicodeString); overload;
/// convert a Delphi 2009+ Unicode string into a WinAnsi (code page 1252) string
function UnicodeStringToWinAnsi(const S: UnicodeString): WinAnsiString; inline;
/// convert our UTF-8 encoded buffer into a Delphi 2009+ Unicode string
// - this function is the same as direct assignment, since RawUTF8=AnsiString(CP_UTF8),
// but is faster, since use no Win32 API call
function UTF8DecodeToUnicodeString(P: PUTF8Char; L: integer): UnicodeString; overload; inline;
/// convert a Win-Ansi encoded buffer into a Delphi 2009+ Unicode string
// - this function is faster than default RTL, since use no Win32 API call
function WinAnsiToUnicodeString(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): UnicodeString; overload;
/// convert a Win-Ansi string into a Delphi 2009+ Unicode string
// - this function is faster than default RTL, since use no Win32 API call
function WinAnsiToUnicodeString(const WinAnsi: WinAnsiString): UnicodeString; inline; overload;
{$endif HASVARUSTRING}
/// convert any generic VCL Text into an UTF-8 encoded String
// - in the VCL context, it's prefered to use TLanguageFile.StringToUTF8()
// method from mORMoti18n, which will handle full i18n of your application
// - it will work as is with Delphi 2009+ (direct unicode conversion)
// - under older version of Delphi (no unicode), it will use the
// current RTL codepage, as with WideString conversion (but without slow
// WideString usage)
function StringToUTF8(const Text: string): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert any generic VCL Text buffer into an UTF-8 encoded String
// - it will work as is with Delphi 2009+ (direct unicode conversion)
// - under older version of Delphi (no unicode), it will use the
// current RTL codepage, as with WideString conversion (but without slow
// WideString usage)
procedure StringToUTF8(Text: PChar; TextLen: PtrInt; var result: RawUTF8); overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert any generic VCL Text into an UTF-8 encoded String
// - this overloaded function use a faster by-reference parameter for the result
procedure StringToUTF8(const Text: string; var result: RawUTF8); overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert any generic VCL Text into an UTF-8 encoded String
function ToUTF8(const Text: string): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert any UTF-8 encoded shortstring Text into an UTF-8 encoded String
// - expects the supplied content to be already ASCII-7 or UTF-8 encoded, e.g.
// a RTTI type or property name: it won't work with Ansi-encoded strings
function ToUTF8(const Ansi7Text: ShortString): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert a TGUID into UTF-8 encoded text
// - will return e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' (without the {})
// - if you need the embracing { }, use GUIDToRawUTF8() function instead
function ToUTF8({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): RawUTF8; overload;
{$ifndef NOVARIANTS}
type
/// function prototype used internally for variant comparison
// - used in mORMot.pas unit e.g. by TDocVariantData.SortByValue
TVariantCompare = function(const V1,V2: variant): PtrInt;
/// TVariantCompare-compatible case-sensitive comparison function
// - just a wrapper around SortDynArrayVariantComp(caseInsensitive=false)
function VariantCompare(const V1,V2: variant): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
/// TVariantCompare-compatible case-insensitive comparison function
// - just a wrapper around SortDynArrayVariantComp(caseInsensitive=true)
function VariantCompareI(const V1,V2: variant): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
/// convert any Variant into UTF-8 encoded String
// - use VariantSaveJSON() instead if you need a conversion to JSON with
// custom parameters
// - note: null will be returned as 'null'
function VariantToUTF8(const V: Variant): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert any Variant into UTF-8 encoded String
// - use VariantSaveJSON() instead if you need a conversion to JSON with
// custom parameters
// - note: null will be returned as 'null'
function ToUTF8(const V: Variant): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert any Variant into UTF-8 encoded String
// - use VariantSaveJSON() instead if you need a conversion to JSON with
// custom parameters
// - wasString is set if the V value was a text
// - empty and null variants will be stored as 'null' text - as expected by JSON
// - custom variant types (e.g. TDocVariant) will be stored as JSON
procedure VariantToUTF8(const V: Variant; var result: RawUTF8;
var wasString: boolean); overload;
/// convert any Variant into UTF-8 encoded String
// - use VariantSaveJSON() instead if you need a conversion to JSON with
// custom parameters
// - returns TRUE if the V value was a text, FALSE if was not (e.g. a number)
// - empty and null variants will be stored as 'null' text - as expected by JSON
// - custom variant types (e.g. TDocVariant) will be stored as JSON
function VariantToUTF8(const V: Variant; var Text: RawUTF8): boolean; overload;
/// convert any date/time Variant into a TDateTime value
// - would handle varDate kind of variant, or use a string conversion and
// ISO-8601 parsing if possible
function VariantToDateTime(const V: Variant; var Value: TDateTime): boolean;
/// fast conversion from hexa chars, supplied as a variant string, into a binary buffer
function VariantHexDisplayToBin(const Hex: variant; Bin: PByte; BinBytes: integer): boolean;
/// fast conversion of a binary buffer into hexa chars, as a variant string
function BinToHexDisplayLowerVariant(Bin: pointer; BinBytes: integer): variant;
{$ifdef HASINLINE}inline;{$endif}
/// fast comparison of a Variant and UTF-8 encoded String (or number)
// - slightly faster than plain V=Str, which computes a temporary variant
// - here Str='' equals unassigned, null or false
// - if CaseSensitive is false, will use IdemPropNameU() for comparison
function VariantEquals(const V: Variant; const Str: RawUTF8;
CaseSensitive: boolean=true): boolean; overload;
/// convert any Variant into a VCL string type
// - expects any varString value to be stored as a RawUTF8
// - prior to Delphi 2009, use VariantToString(aVariant) instead of
// string(aVariant) to safely retrieve a string=AnsiString value from a variant
// generated by our framework units - otherwise, you may loose encoded characters
// - for Unicode versions of Delphi, there won't be any potential data loss,
// but this version may be slightly faster than a string(aVariant)
function VariantToString(const V: Variant): string;
/// convert any Variant into a value encoded as with :(..:) inlined parameters
// in FormatUTF8(Format,Args,Params)
procedure VariantToInlineValue(const V: Variant; var result: RawUTF8);
/// convert any Variant into another Variant storing an RawUTF8 of the value
// - e.g. VariantToVariantUTF8('toto')='toto' and VariantToVariantUTF8(12)='12'
function VariantToVariantUTF8(const V: Variant): variant;
/// faster alternative to Finalize(aVariantDynArray)
// - this function will take account and optimize the release of a dynamic
// array of custom variant types values
// - for instance, an array of TDocVariant will be optimized for speed
procedure VariantDynArrayClear(var Value: TVariantDynArray);
{$ifdef HASINLINE}inline;{$endif}
/// crc32c-based hash of a variant value
// - complex string types will make up to 255 uppercase characters conversion
// if CaseInsensitive is true
// - you can specify your own hashing function if crc32c is not what you expect
function VariantHash(const value: variant; CaseInsensitive: boolean;
Hasher: THasher=nil): cardinal;
{$endif NOVARIANTS}
{ note: those VariantToInteger*() functions are expected to be there }
/// convert any numerical Variant into a 32-bit integer
// - it will expect true numerical Variant and won't convert any string nor
// floating-pointer Variant, which will return FALSE and won't change the
// Value variable content
function VariantToInteger(const V: Variant; var Value: integer): boolean;
/// convert any numerical Variant into a 64-bit integer
// - it will expect true numerical Variant and won't convert any string nor
// floating-pointer Variant, which will return FALSE and won't change the
// Value variable content
function VariantToInt64(const V: Variant; var Value: Int64): boolean;
/// convert any numerical Variant into a 64-bit integer
// - it will expect true numerical Variant and won't convert any string nor
// floating-pointer Variant, which will return the supplied DefaultValue
function VariantToInt64Def(const V: Variant; DefaultValue: Int64): Int64;
/// convert any numerical Variant into a floating point value
function VariantToDouble(const V: Variant; var Value: double): boolean;
/// convert any numerical Variant into a floating point value
function VariantToDoubleDef(const V: Variant; const default: double=0): double;
/// convert any numerical Variant into a fixed decimals floating point value
function VariantToCurrency(const V: Variant; var Value: currency): boolean;
/// convert any numerical Variant into a boolean value
// - text content will return true after case-insensitive 'true' comparison
function VariantToBoolean(const V: Variant; var Value: Boolean): boolean;
/// convert any numerical Variant into an integer
// - it will expect true numerical Variant and won't convert any string nor
// floating-pointer Variant, which will return the supplied DefaultValue
function VariantToIntegerDef(const V: Variant; DefaultValue: integer): integer; overload;
/// convert any generic VCL Text buffer into an UTF-8 encoded buffer
// - Dest must be able to receive at least SourceChars*3 bytes
// - it will work as is with Delphi 2009+ (direct unicode conversion)
// - under older version of Delphi (no unicode), it will use the
// current RTL codepage, as with WideString conversion (but without slow
// WideString usage)
function StringBufferToUtf8(Dest: PUTF8Char; Source: PChar; SourceChars: PtrInt): PUTF8Char; overload;
/// convert any generic VCL 0-terminated Text buffer into an UTF-8 string
// - it will work as is with Delphi 2009+ (direct unicode conversion)
// - under older version of Delphi (no unicode), it will use the
// current RTL codepage, as with WideString conversion (but without slow
// WideString usage)
procedure StringBufferToUtf8(Source: PChar; out result: RawUTF8); overload;
/// convert any generic VCL Text into a Raw Unicode encoded String
// - it's prefered to use TLanguageFile.StringToUTF8() method in mORMoti18n,
// which will handle full i18n of your application
// - it will work as is with Delphi 2009+ (direct unicode conversion)
// - under older version of Delphi (no unicode), it will use the
// current RTL codepage, as with WideString conversion (but without slow
// WideString usage)
function StringToRawUnicode(const S: string): RawUnicode; overload;
/// convert any generic VCL Text into a SynUnicode encoded String
// - it's prefered to use TLanguageFile.StringToUTF8() method in mORMoti18n,
// which will handle full i18n of your application
// - it will work as is with Delphi 2009+ (direct unicode conversion)
// - under older version of Delphi (no unicode), it will use the
// current RTL codepage, as with WideString conversion (but without slow
// WideString usage)
function StringToSynUnicode(const S: string): SynUnicode; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert any generic VCL Text into a SynUnicode encoded String
// - overloaded to avoid a copy to a temporary result string of a function
procedure StringToSynUnicode(const S: string; var result: SynUnicode); overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert any generic VCL Text into a Raw Unicode encoded String
// - it's prefered to use TLanguageFile.StringToUTF8() method in mORMoti18n,
// which will handle full i18n of your application
// - it will work as is with Delphi 2009+ (direct unicode conversion)
// - under older version of Delphi (no unicode), it will use the
// current RTL codepage, as with WideString conversion (but without slow
// WideString usage)
function StringToRawUnicode(P: PChar; L: integer): RawUnicode; overload;
/// convert any Raw Unicode encoded string into a generic VCL Text
// - uses StrLenW() and not length(U) to handle case when was used as buffer
function RawUnicodeToString(const U: RawUnicode): string; overload;
/// convert any Raw Unicode encoded buffer into a generic VCL Text
function RawUnicodeToString(P: PWideChar; L: integer): string; overload;
/// convert any Raw Unicode encoded buffer into a generic VCL Text
procedure RawUnicodeToString(P: PWideChar; L: integer; var result: string); overload;
/// convert any SynUnicode encoded string into a generic VCL Text
function SynUnicodeToString(const U: SynUnicode): string;
{$ifdef HASINLINE}inline;{$endif}
/// convert any UTF-8 encoded String into a generic VCL Text
// - it's prefered to use TLanguageFile.UTF8ToString() in mORMoti18n,
// which will handle full i18n of your application
// - it will work as is with Delphi 2009+ (direct unicode conversion)
// - under older version of Delphi (no unicode), it will use the
// current RTL codepage, as with WideString conversion (but without slow
// WideString usage)
function UTF8ToString(const Text: RawUTF8): string;
{$ifdef HASINLINE}inline;{$endif}
/// convert any UTF-8 encoded buffer into a generic VCL Text
// - it's prefered to use TLanguageFile.UTF8ToString() in mORMoti18n,
// which will handle full i18n of your application
// - it will work as is with Delphi 2009+ (direct unicode conversion)
// - under older version of Delphi (no unicode), it will use the
// current RTL codepage, as with WideString conversion (but without slow
// WideString usage)
function UTF8DecodeToString(P: PUTF8Char; L: integer): string; overload;
{$ifdef UNICODE}inline;{$endif}
/// convert any UTF-8 encoded buffer into a generic VCL Text
procedure UTF8DecodeToString(P: PUTF8Char; L: integer; var result: string); overload;
/// convert any UTF-8 encoded String into a generic WideString Text
function UTF8ToWideString(const Text: RawUTF8): WideString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert any UTF-8 encoded String into a generic WideString Text
procedure UTF8ToWideString(const Text: RawUTF8; var result: WideString); overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert any UTF-8 encoded String into a generic WideString Text
procedure UTF8ToWideString(Text: PUTF8Char; Len: PtrInt; var result: WideString); overload;
/// convert any UTF-8 encoded String into a generic SynUnicode Text
function UTF8ToSynUnicode(const Text: RawUTF8): SynUnicode; overload;
/// convert any UTF-8 encoded String into a generic SynUnicode Text
procedure UTF8ToSynUnicode(const Text: RawUTF8; var result: SynUnicode); overload;
/// convert any UTF-8 encoded buffer into a generic SynUnicode Text
procedure UTF8ToSynUnicode(Text: PUTF8Char; Len: PtrInt; var result: SynUnicode); overload;
/// convert any Ansi 7 bit encoded String into a generic VCL Text
// - the Text content must contain only 7 bit pure ASCII characters
function Ansi7ToString(const Text: RawByteString): string; overload;
{$ifndef UNICODE}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// convert any Ansi 7 bit encoded String into a generic VCL Text
// - the Text content must contain only 7 bit pure ASCII characters
function Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt): string; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert any Ansi 7 bit encoded String into a generic VCL Text
// - the Text content must contain only 7 bit pure ASCII characters
procedure Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt; var result: string); overload;
/// convert any generic VCL Text into Ansi 7 bit encoded String
// - the Text content must contain only 7 bit pure ASCII characters
function StringToAnsi7(const Text: string): RawByteString;
/// convert any generic VCL Text into WinAnsi (Win-1252) 8 bit encoded String
function StringToWinAnsi(const Text: string): WinAnsiString;
{$ifdef UNICODE}inline;{$endif}
/// fast Format() function replacement, optimized for RawUTF8
// - only supported token is %, which will be written in the resulting string
// according to each Args[] supplied items - so you will never get any exception
// as with the SysUtils.Format() when a specifier is incorrect
// - resulting string has no length limit and uses fast concatenation
// - there is no escape char, so to output a '%' character, you need to use '%'
// as place-holder, and specify '%' as value in the Args array
// - note that, due to a Delphi compiler limitation, cardinal values should be
// type-casted to Int64() (otherwise the integer mapped value will be converted)
// - any supplied TObject instance will be written as their class name
function FormatUTF8(const Format: RawUTF8; const Args: array of const): RawUTF8; overload;
/// fast Format() function replacement, optimized for RawUTF8
// - overloaded function, which avoid a temporary RawUTF8 instance on stack
procedure FormatUTF8(const Format: RawUTF8; const Args: array of const;
out result: RawUTF8); overload;
/// fast Format() function replacement, tuned for direct memory buffer write
// - use the same single token % (and implementation) than FormatUTF8()
// - returns the number of UTF-8 bytes appended to Dest^
function FormatBuffer(const Format: RawUTF8; const Args: array of const;
Dest: pointer; DestLen: PtrInt): PtrInt;
/// fast Format() function replacement, for UTF-8 content stored in shortstring
// - use the same single token % (and implementation) than FormatUTF8()
// - shortstring allows fast stack allocation, so is perfect for small content
// - truncate result if the text size exceeds 255 bytes
procedure FormatShort(const Format: RawUTF8; const Args: array of const;
var result: shortstring);
/// fast Format() function replacement, for UTF-8 content stored in shortstring
function FormatToShort(const Format: RawUTF8; const Args: array of const): shortstring;
/// fast Format() function replacement, tuned for small content
// - use the same single token % (and implementation) than FormatUTF8()
procedure FormatString(const Format: RawUTF8; const Args: array of const;
out result: string); overload;
/// fast Format() function replacement, tuned for small content
// - use the same single token % (and implementation) than FormatUTF8()
function FormatString(const Format: RawUTF8; const Args: array of const): string; overload;
{$ifdef FPC}inline;{$endif}
type
/// used e.g. by PointerToHexShort/CardinalToHexShort/Int64ToHexShort/FormatShort16
// - such result type would avoid a string allocation on heap, so are highly
// recommended e.g. when logging small pieces of information
TShort16 = string[16];
PShort16 = ^TShort16;
/// fast Format() function replacement, for UTF-8 content stored in TShort16
// - truncate result if the text size exceeds 16 bytes
procedure FormatShort16(const Format: RawUTF8; const Args: array of const;
var result: TShort16);
/// fast Format() function replacement, handling % and ? parameters
// - will include Args[] for every % in Format
// - will inline Params[] for every ? in Format, handling special "inlined"
// parameters, as exected by mORMot.pas unit, i.e. :(1234): for numerical
// values, and :('quoted '' string'): for textual values
// - if optional JSONFormat parameter is TRUE, ? parameters will be written
// as JSON quoted strings, without :(...): tokens, e.g. "quoted "" string"
// - resulting string has no length limit and uses fast concatenation
// - note that, due to a Delphi compiler limitation, cardinal values should be
// type-casted to Int64() (otherwise the integer mapped value will be converted)
// - any supplied TObject instance will be written as their class name
function FormatUTF8(const Format: RawUTF8; const Args, Params: array of const;
JSONFormat: boolean=false): RawUTF8; overload;
/// read and store text into values[] according to fmt specifiers
// - %d as PInteger, %D as PInt64, %u as PCardinal, %U as PQWord, %f as PDouble,
// %F as PCurrency, %x as 8 hexa chars to PInteger, %X as 16 hexa chars to PInt64,
// %s as PShortString (UTF-8 encoded), %S as PRawUTF8, %L as PRawUTF8 (getting
// all text until the end of the line)
// - optionally, specifiers and any whitespace separated identifiers may be
// extracted and stored into the ident[] array, e.g. '%dFirstInt %s %DOneInt64'
// will store ['dFirstInt','s','DOneInt64'] into ident
function ScanUTF8(const text, fmt: RawUTF8; const values: array of pointer;
ident: PRawUTF8DynArray=nil): integer; overload;
/// read text from P/PLen and store it into values[] according to fmt specifiers
function ScanUTF8(P: PUTF8Char; PLen: PtrInt; const fmt: RawUTF8;
const values: array of pointer; ident: PRawUTF8DynArray): integer; overload;
/// convert an open array (const Args: array of const) argument to an UTF-8
// encoded text
// - note that, due to a Delphi compiler limitation, cardinal values should be
// type-casted to Int64() (otherwise the integer mapped value will be converted)
// - any supplied TObject instance will be written as their class name
procedure VarRecToUTF8(const V: TVarRec; var result: RawUTF8;
wasString: PBoolean=nil);
type
/// a memory structure which avoids a temporary RawUTF8 allocation
// - used by VarRecToTempUTF8() and FormatUTF8()/FormatShort()
TTempUTF8 = record
Len: PtrInt;
Text: PUTF8Char;
TempRawUTF8: pointer;
Temp: array[0..23] of AnsiChar;
end;
PTempUTF8 = ^TTempUTF8;
/// convert an open array (const Args: array of const) argument to an UTF-8
// encoded text, using a specified temporary buffer
// - this function would allocate a RawUTF8 in TempRawUTF8 only if needed,
// but use the supplied Res.Temp[] buffer for numbers to text conversion -
// caller should ensure to make RawUTF8(TempRawUTF8) := '' on the entry
// - it would return the number of UTF-8 bytes, i.e. Res.Len
// - note that, due to a Delphi compiler limitation, cardinal values should be
// type-casted to Int64() (otherwise the integer mapped value will be converted)
// - any supplied TObject instance will be written as their class name
function VarRecToTempUTF8(const V: TVarRec; var Res: TTempUTF8): integer;
/// convert an open array (const Args: array of const) argument to an UTF-8
// encoded text, returning FALSE if the argument was not a string value
function VarRecToUTF8IsString(const V: TVarRec; var value: RawUTF8): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// convert an open array (const Args: array of const) argument to an Int64
// - returns TRUE and set Value if the supplied argument is a vtInteger, vtInt64
// or vtBoolean
// - returns FALSE if the argument is not an integer
// - note that, due to a Delphi compiler limitation, cardinal values should be
// type-casted to Int64() (otherwise the integer mapped value will be converted)
function VarRecToInt64(const V: TVarRec; out value: Int64): boolean;
/// convert an open array (const Args: array of const) argument to a floating
// point value
// - returns TRUE and set Value if the supplied argument is a number (e.g.
// vtInteger, vtInt64, vtCurrency or vtExtended)
// - returns FALSE if the argument is not a number
// - note that, due to a Delphi compiler limitation, cardinal values should be
// type-casted to Int64() (otherwise the integer mapped value will be converted)
function VarRecToDouble(const V: TVarRec; out value: double): boolean;
/// convert an open array (const Args: array of const) argument to a value
// encoded as with :(...): inlined parameters in FormatUTF8(Format,Args,Params)
// - note that, due to a Delphi compiler limitation, cardinal values should be
// type-casted to Int64() (otherwise the integer mapped value will be converted)
// - any supplied TObject instance will be written as their class name
procedure VarRecToInlineValue(const V: TVarRec; var result: RawUTF8);
/// get an open array (const Args: array of const) character argument
// - only handle varChar and varWideChar kind of arguments
function VarRecAsChar(const V: TVarRec): integer;
{$ifdef HASINLINE}inline;{$endif}
type
/// function prototype used internally for UTF-8 buffer comparison
// - used in mORMot.pas unit during TSQLTable rows sort and by TSQLQuery
TUTF8Compare = function(P1,P2: PUTF8Char): PtrInt;
/// convert the endianness of a given unsigned 32-bit integer into BigEndian
function bswap32(a: cardinal): cardinal;
{$ifndef CPUINTEL}inline;{$endif}
/// convert the endianness of a given unsigned 64-bit integer into BigEndian
function bswap64({$ifdef FPC_X86}constref{$else}const{$endif} a: QWord): QWord;
{$ifndef CPUINTEL}inline;{$endif}
/// convert the endianness of an array of unsigned 64-bit integer into BigEndian
// - n is required to be > 0
// - warning: on x86, a should be <> b
procedure bswap64array(a,b: PQWordArray; n: PtrInt);
/// fast concatenation of several AnsiStrings
function RawByteStringArrayConcat(const Values: array of RawByteString): RawByteString;
/// creates a TBytes from a RawByteString memory buffer
procedure RawByteStringToBytes(const buf: RawByteString; out bytes: TBytes);
/// creates a RawByteString memory buffer from a TBytes content
procedure BytesToRawByteString(const bytes: TBytes; out buf: RawByteString);
{$ifdef HASINLINE}inline;{$endif}
/// creates a RawByteString memory buffer from an embedded resource
// - returns '' if the resource is not found
// - warning: resources size may be rounded up to alignment
// - you can specify a library (dll) resource instance handle, if needed
procedure ResourceToRawByteString(const ResName: string; ResType: PChar;
out buf: RawByteString; Instance: THandle=0);
/// creates a RawByteString memory buffer from an SynLZ-compressed embedded resource
// - returns '' if the resource is not found
// - this method would use SynLZDecompress() after ResourceToRawByteString(),
// with a ResType=PChar(10) (i.e. RC_DATA)
// - you can specify a library (dll) resource instance handle, if needed
procedure ResourceSynLZToRawByteString(const ResName: string;
out buf: RawByteString; Instance: THandle=0);
{$ifndef ENHANCEDRTL} { is our Enhanced Runtime (or LVCL) library not installed? }
/// fast dedicated RawUTF8 version of Trim()
// - implemented using x86 asm, if possible
// - this Trim() is seldom used, but this RawUTF8 specific version is needed
// e.g. by Delphi 2009+, to avoid two unnecessary conversions into UnicodeString
// - in the middle of VCL code, consider using TrimU() which won't have name
// collision ambiguity as with SysUtils' homonymous function
function Trim(const S: RawUTF8): RawUTF8;
/// fast dedicated RawUTF8 version of Trim()
// - could be used if overloaded Trim() from SysUtils.pas is ambiguous
function TrimU(const S: RawUTF8): RawUTF8;
{$ifdef HASINLINE}inline;{$endif}
{$define OWNNORMTOUPPER} { NormToUpper[] exists only in our enhanced RTL }
{$endif ENHANCEDRTL}
/// our fast version of CompareMem() with optimized asm for x86 and tune pascal
function CompareMem(P1, P2: Pointer; Length: PtrInt): Boolean;
{$ifdef HASINLINE}
function CompareMemFixed(P1, P2: Pointer; Length: PtrInt): Boolean; inline;
{$else}
/// a CompareMem()-like function designed for small and fixed-sized content
// - here, Length is expected to be a constant value - typically from sizeof() -
// so that inlining has better performance than calling the CompareMem() function
var CompareMemFixed: function(P1, P2: Pointer; Length: PtrInt): Boolean = CompareMem;
{$endif HASINLINE}
/// a CompareMem()-like function designed for small (a few bytes) content
function CompareMemSmall(P1, P2: Pointer; Length: PtrUInt): Boolean; {$ifdef HASINLINE}inline;{$endif}
/// convert some ASCII-7 text into binary, using Emile Baudot code
// - as used in telegraphs, covering #10 #13 #32 a-z 0-9 - ' , ! : ( + ) $ ? @ . / ;
// charset, following a custom static-huffman-like encoding with 5-bit masks
// - any upper case char will be converted into lowercase during encoding
// - other characters (e.g. UTF-8 accents, or controls chars) will be ignored
// - resulting binary will consume 5 (or 10) bits per character
// - reverse of the BaudotToAscii() function
// - the "baud" symbol rate measurement comes from Emile's name ;)
function AsciiToBaudot(P: PAnsiChar; len: PtrInt): RawByteString; overload;
/// convert some ASCII-7 text into binary, using Emile Baudot code
// - as used in telegraphs, covering #10 #13 #32 a-z 0-9 - ' , ! : ( + ) $ ? @ . / ;
// charset, following a custom static-huffman-like encoding with 5-bit masks
// - any upper case char will be converted into lowercase during encoding
// - other characters (e.g. UTF-8 accents, or controls chars) will be ignored
// - resulting binary will consume 5 (or 10) bits per character
// - reverse of the BaudotToAscii() function
// - the "baud" symbol rate measurement comes from Emile's name ;)
function AsciiToBaudot(const Text: RawUTF8): RawByteString; overload;
/// convert some Baudot code binary, into ASCII-7 text
// - reverse of the AsciiToBaudot() function
// - any uppercase character would be decoded as lowercase - and some characters
// may have disapeared
// - the "baud" symbol rate measurement comes from Emile's name ;)
function BaudotToAscii(Baudot: PByteArray; len: PtrInt): RawUTF8; overload;
/// convert some Baudot code binary, into ASCII-7 text
// - reverse of the AsciiToBaudot() function
// - any uppercase character would be decoded as lowercase - and some characters
// may have disapeared
// - the "baud" symbol rate measurement comes from Emile's name ;)
function BaudotToAscii(const Baudot: RawByteString): RawUTF8; overload;
{$ifdef UNICODE}
/// our fast RawUTF8 version of Pos(), for Unicode only compiler
// - this Pos() is seldom used, but this RawUTF8 specific version is needed
// by Delphi 2009+, to avoid two unnecessary conversions into UnicodeString
// - just a wrapper around PosEx(substr,str,1)
function Pos(const substr, str: RawUTF8): Integer; overload; inline;
{$endif UNICODE}
/// use our fast RawUTF8 version of IntToStr()
// - without any slow UnicodeString=String->AnsiString conversion for Delphi 2009
// - only useful if our Enhanced Runtime (or LVCL) library is not installed
function Int64ToUtf8(Value: Int64): RawUTF8; overload;
{$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// fast RawUTF8 version of IntToStr(), with proper QWord conversion
procedure UInt64ToUtf8(Value: QWord; var result: RawUTF8);
/// use our fast RawUTF8 version of IntToStr()
// - without any slow UnicodeString=String->AnsiString conversion for Delphi 2009
// - only useful if our Enhanced Runtime (or LVCL) library is not installed
function Int32ToUtf8(Value: PtrInt): RawUTF8; overload;
{$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// use our fast RawUTF8 version of IntToStr()
// - without any slow UnicodeString=String->AnsiString conversion for Delphi 2009
// - result as var parameter saves a local assignment and a try..finally
procedure Int32ToUTF8(Value: PtrInt; var result: RawUTF8); overload;
{$ifdef HASINLINE}inline;{$endif}
/// use our fast RawUTF8 version of IntToStr()
// - without any slow UnicodeString=String->AnsiString conversion for Delphi 2009
// - result as var parameter saves a local assignment and a try..finally
procedure Int64ToUtf8(Value: Int64; var result: RawUTF8); overload;
{$ifdef HASINLINE}inline;{$endif}
/// use our fast RawUTF8 version of IntToStr()
function ToUTF8(Value: PtrInt): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
{$ifndef CPU64}
/// use our fast RawUTF8 version of IntToStr()
function ToUTF8(Value: Int64): RawUTF8; overload;
{$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif}
{$endif}
/// optimized conversion of a cardinal into RawUTF8
function UInt32ToUtf8(Value: PtrUInt): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// optimized conversion of a cardinal into RawUTF8
procedure UInt32ToUtf8(Value: PtrUInt; var result: RawUTF8); overload;
{$ifdef HASINLINE}inline;{$endif}
/// faster version than default SysUtils.IntToStr implementation
function IntToString(Value: integer): string; overload;
/// faster version than default SysUtils.IntToStr implementation
function IntToString(Value: cardinal): string; overload;
/// faster version than default SysUtils.IntToStr implementation
function IntToString(Value: Int64): string; overload;
/// convert a floating-point value to its numerical text equivalency
function DoubleToString(Value: Double): string;
/// convert a currency value from its Int64 binary representation into
// its numerical text equivalency
// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals)
function Curr64ToString(Value: Int64): string;
type
/// used to store a set of 8-bit encoded characters
TSynAnsicharSet = set of AnsiChar;
/// used to store a set of 8-bit unsigned integers
TSynByteSet = set of Byte;
/// check all character within text are spaces or control chars
// - i.e. a faster alternative to trim(text)=''
function IsVoid(const text: RawUTF8): boolean;
/// returns the supplied text content, without any control char
// - a control char has an ASCII code #0 .. #32, i.e. text[]<=' '
// - you can specify a custom char set to be excluded, if needed
function TrimControlChars(const text: RawUTF8; const controls: TSynAnsicharSet=[#0..' ']): RawUTF8;
var
/// best possible precision when rendering a "single" kind of float
// - can be used as parameter for ExtendedToShort/ExtendedToStr
// - is defined as a var, so that you may be able to override the default
// settings, for the whole process
SINGLE_PRECISION: integer = 8;
/// best possible precision when rendering a "double" kind of float
// - can be used as parameter for ExtendedToShort/ExtendedToStr
// - is defined as a var, so that you may be able to override the default
// settings, for the whole process
DOUBLE_PRECISION: integer = 15;
/// best possible precision when rendering a "extended" kind of float
// - can be used as parameter for ExtendedToShort/ExtendedToStr
// - is defined as a var, so that you may be able to override the default
// settings, for the whole process
EXTENDED_PRECISION: integer = 18;
const
/// a typical error allowed when working with double floating-point values
// - 1E-12 is too small, and triggers sometimes some unexpected errors;
// FPC RTL uses 1E-4 so we are paranoid enough
DOUBLE_SAME = 1E-11;
type
{$ifdef TSYNEXTENDED80}
/// the floating-point type to be used for best precision and speed
// - will allow to fallback to double e.g. on x64 and ARM CPUs
TSynExtended = extended;
{$else}
/// ARM/Delphi 64-bit does not support 80bit extended -> double is enough
TSynExtended = double;
{$endif TSYNEXTENDED80}
/// the non-number values potentially stored in an IEEE floating point
TFloatNan = (fnNumber, fnNan, fnInf, fnNegInf);
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
/// will actually change anything only on FPC ARM/Aarch64 plaforms
unaligned = Double;
{$endif}
const
/// the JavaScript-like values of non-number IEEE constants
// - as recognized by FloatToShortNan, and used by TTextWriter.Add()
// when serializing such single/double/extended floating-point values
JSON_NAN: array[TFloatNan] of string[11] = (
'0', '"NaN"', '"Infinity"', '"-Infinity"');
type
/// small structure used as convenient result to Div100() procedure
TDiv100Rec = packed record
/// contains V div 100 after Div100(V)
D: cardinal;
/// contains V mod 100 after Div100(V)
M: cardinal;
end;
/// simple wrapper to efficiently compute both division and modulo per 100
// - compute result.D = Y div 100 and result.M = Y mod 100
// - under FPC, will use fast multiplication by reciprocal so can be inlined
// - under Delphi, we use our own optimized asm version (which can't be inlined)
procedure Div100(Y: cardinal; var res: TDiv100Rec);
{$ifdef FPC} inline; {$endif}
/// compare to floating point values, with IEEE 754 double precision
// - use this function instead of raw = operator
// - the precision is calculated from the A and B value range
// - faster equivalent than SameValue() in Math unit
// - if you know the precision range of A and B, it's faster to check abs(A-B)<range
function SameValue(const A, B: Double; DoublePrec: double = DOUBLE_SAME): 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 = DOUBLE_SAME): Boolean;
/// a comparison function for sorting IEEE 754 double precision values
function CompareFloat(const A, B: double): integer;
{$ifdef HASINLINE}inline;{$endif}
/// a comparison function for sorting 32-bit signed integer values
function CompareInteger(const A, B: integer): integer;
{$ifdef HASINLINE}inline;{$endif}
/// a comparison function for sorting 64-bit signed integer values
function CompareInt64(const A, B: Int64): integer;
{$ifdef HASINLINE}inline;{$endif}
/// a comparison function for sorting 32-bit unsigned integer values
function CompareCardinal(const A, B: cardinal): integer;
{$ifdef HASINLINE}inline;{$endif}
/// a comparison function for sorting 64-bit unsigned integer values
// - note that QWord(A)>QWord(B) is wrong on older versions of Delphi, so you
// should better use this function or SortDynArrayQWord() to properly compare
// two QWord values over CPUX86
function CompareQWord(A, B: QWord): integer;
{$ifdef HASINLINE}inline;{$endif}
/// compute the sum of values, using a running compensation for lost low-order bits
// - a naive "Sum := Sum + Data" will be restricted to 53 bits of resolution,
// so will eventually result in an incorrect number
// - Kahan algorithm keeps track of the accumulated error in integer operations,
// to achieve a precision of more than 100 bits
// - see https://en.wikipedia.org/wiki/Kahan_summation_algorithm
procedure KahanSum(const Data: double; var Sum, Carry: double);
{$ifdef HASINLINE}inline;{$endif}
/// convert a floating-point value to its numerical text equivalency
// - on Delphi Win32, calls FloatToText() in ffGeneral mode; on FPC uses str()
// - DOUBLE_PRECISION will redirect to DoubleToShort() and its faster Fabian
// Loitsch's Grisu algorithm if available
// - returns the count of chars stored into S, i.e. length(S)
function ExtendedToShort(var S: ShortString; Value: TSynExtended; Precision: integer): integer;
/// convert a floating-point value to its numerical text equivalency without
// scientification notation
// - DOUBLE_PRECISION will redirect to DoubleToShortNoExp() and its faster Fabian
// Loitsch's Grisu algorithm if available - or calls str(Value:0:precision,S)
// - returns the count of chars stored into S, i.e. length(S)
function ExtendedToShortNoExp(var S: ShortString; Value: TSynExtended;
Precision: integer): integer;
/// check if the supplied text is NAN/INF/+INF/-INF, i.e. not a number
// - as returned by ExtendedToShort/DoubleToShort textual conversion
// - such values do appear as IEEE floating points, but are not defined in JSON
function FloatToShortNan(const s: shortstring): TFloatNan;
{$ifdef HASINLINE}inline;{$endif}
/// check if the supplied text is NAN/INF/+INF/-INF, i.e. not a number
// - as returned e.g. by ExtendedToStr/DoubleToStr textual conversion
// - such values do appear as IEEE floating points, but are not defined in JSON
function FloatToStrNan(const s: RawUTF8): TFloatNan;
{$ifdef HASINLINE}inline;{$endif}
/// convert a floating-point value to its numerical text equivalency
function ExtendedToStr(Value: TSynExtended; Precision: integer): RawUTF8; overload;
/// convert a floating-point value to its numerical text equivalency
procedure ExtendedToStr(Value: TSynExtended; Precision: integer; var result: RawUTF8); overload;
/// recognize if the supplied text is NAN/INF/+INF/-INF, i.e. not a number
// - returns the number as text (stored into tmp variable), or "Infinity",
// "-Infinity", and "NaN" for corresponding IEEE special values
// - result is a PShortString either over tmp, or JSON_NAN[]
function FloatToJSONNan(const s: ShortString): PShortString;
{$ifdef HASINLINE}inline;{$endif}
/// convert a floating-point value to its JSON text equivalency
// - depending on the platform, it may either call str() or FloatToText()
// in ffGeneral mode (the shortest possible decimal string using fixed or
// scientific format)
// - returns the number as text (stored into tmp variable), or "Infinity",
// "-Infinity", and "NaN" for corresponding IEEE special values
// - result is a PShortString either over tmp, or JSON_NAN[]
function ExtendedToJSON(var tmp: ShortString; Value: TSynExtended;
Precision: integer; NoExp: boolean): PShortString;
/// convert a 64-bit floating-point value to its numerical text equivalency
// - on Delphi Win32, calls FloatToText() in ffGeneral mode
// - on other platforms, i.e. Delphi Win64 and all FPC targets, will use our own
// faster Fabian Loitsch's Grisu algorithm implementation
// - returns the count of chars stored into S, i.e. length(S)
function DoubleToShort(var S: ShortString; const Value: double): integer;
{$ifdef FPC}inline;{$endif}
/// convert a 64-bit floating-point value to its numerical text equivalency
// without scientific notation
// - on Delphi Win32, calls FloatToText() in ffGeneral mode
// - on other platforms, i.e. Delphi Win64 and all FPC targets, will use our own
// faster Fabian Loitsch's Grisu algorithm implementation
// - returns the count of chars stored into S, i.e. length(S)
function DoubleToShortNoExp(var S: ShortString; const Value: double): integer;
{$ifdef FPC}inline;{$endif}
{$ifdef DOUBLETOSHORT_USEGRISU}
const
// special text returned if the double is not a number
C_STR_INF: string[3] = 'Inf';
C_STR_QNAN: string[3] = 'Nan';
// min_width parameter special value, as used internally by FPC for str(d,s)
// - DoubleToAscii() only accept C_NO_MIN_WIDTH or 0 for min_width: space
// trailing has been removed in this cut-down version
C_NO_MIN_WIDTH = -32767;
/// raw function to convert a 64-bit double into a shortstring, stored in str
// - implements Fabian Loitsch's Grisu algorithm dedicated to double values
// - currently, SynCommnons only set min_width=0 (for DoubleToShortNoExp to avoid
// any scientific notation ) or min_width=C_NO_MIN_WIDTH (for DoubleToShort to
// force the scientific notation when the double cannot be represented as
// a simple fractinal number)
procedure DoubleToAscii(min_width, frac_digits: integer; const v: double; str: PAnsiChar);
{$endif DOUBLETOSHORT_USEGRISU}
/// convert a 64-bit floating-point value to its JSON text equivalency
// - on Delphi Win32, calls FloatToText() in ffGeneral mode
// - on other platforms, i.e. Delphi Win64 and all FPC targets, will use our own
// faster Fabian Loitsch's Grisu algorithm
// - returns the number as text (stored into tmp variable), or "Infinity",
// "-Infinity", and "NaN" for corresponding IEEE special values
// - result is a PShortString either over tmp, or JSON_NAN[]
function DoubleToJSON(var tmp: ShortString; Value: double; NoExp: boolean): PShortString;
/// convert a 64-bit floating-point value to its numerical text equivalency
function DoubleToStr(Value: Double): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert a 64-bit floating-point value to its numerical text equivalency
procedure DoubleToStr(Value: Double; var result: RawUTF8); overload;
/// fast retrieve the position of a given character
function PosChar(Str: PUTF8Char; Chr: AnsiChar): PUTF8Char;
{$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// fast retrieve the position of any value of a given set of characters
// - see also strspn() function which is likely to be faster
function PosCharAny(Str: PUTF8Char; Characters: PAnsiChar): PUTF8Char;
/// a non case-sensitive RawUTF8 version of Pos()
// - uppersubstr is expected to be already in upper case
// - this version handle only 7 bit ASCII (no accentuated characters)
function PosI(uppersubstr: PUTF8Char; const str: RawUTF8): PtrInt;
/// a non case-sensitive version of Pos()
// - uppersubstr is expected to be already in upper case
// - this version handle only 7 bit ASCII (no accentuated characters)
function StrPosI(uppersubstr,str: PUTF8Char): PUTF8Char;
/// a non case-sensitive RawUTF8 version of Pos()
// - substr is expected to be already in upper case
// - this version will decode the UTF-8 content before using NormToUpper[]
function PosIU(substr: PUTF8Char; const str: RawUTF8): Integer;
/// internal fast integer val to text conversion
// - expect the last available temporary char position in P
// - return the last written char position (write in reverse order in P^)
// - typical use:
// !function Int32ToUTF8(Value: PtrInt): RawUTF8;
// !var tmp: array[0..23] of AnsiChar;
// ! P: PAnsiChar;
// !begin
// ! P := StrInt32(@tmp[23],Value);
// ! SetString(result,P,@tmp[23]-P);
// !end;
// - convert the input value as PtrInt, so as Int64 on 64-bit CPUs
// - not to be called directly: use IntToStr() or Int32ToUTF8() instead
function StrInt32(P: PAnsiChar; val: PtrInt): PAnsiChar;
/// internal fast unsigned integer val to text conversion
// - expect the last available temporary char position in P
// - return the last written char position (write in reverse order in P^)
// - convert the input value as PtrUInt, so as QWord on 64-bit CPUs
function StrUInt32(P: PAnsiChar; val: PtrUInt): PAnsiChar;
/// internal fast Int64 val to text conversion
// - same calling convention as with StrInt32() above
function StrInt64(P: PAnsiChar; const val: Int64): PAnsiChar;
{$ifdef HASINLINE}inline;{$endif}
/// internal fast unsigned Int64 val to text conversion
// - same calling convention as with StrInt32() above
function StrUInt64(P: PAnsiChar; const val: QWord): PAnsiChar;
{$ifdef CPU64}inline;{$endif}
/// fast add some characters to a RawUTF8 string
// - faster than SetString(tmp,Buffer,BufferLen); Text := Text+tmp;
procedure AppendBufferToRawUTF8(var Text: RawUTF8; Buffer: pointer; BufferLen: PtrInt);
/// fast add one character to a RawUTF8 string
// - faster than Text := Text + ch;
procedure AppendCharToRawUTF8(var Text: RawUTF8; Ch: AnsiChar);
/// fast add some characters to a RawUTF8 string
// - faster than Text := Text+RawUTF8(Buffers[0])+RawUTF8(Buffers[0])+...
procedure AppendBuffersToRawUTF8(var Text: RawUTF8; const Buffers: array of PUTF8Char);
/// fast add some characters from a RawUTF8 string into a given buffer
// - warning: the Buffer should contain enough space to store the Text, otherwise
// you may encounter buffer overflows and random memory errors
function AppendRawUTF8ToBuffer(Buffer: PUTF8Char; const Text: RawUTF8): PUTF8Char;
/// fast add text conversion of a 32-bit unsigned integer value into a given buffer
// - warning: the Buffer should contain enough space to store the text, otherwise
// you may encounter buffer overflows and random memory errors
function AppendUInt32ToBuffer(Buffer: PUTF8Char; Value: PtrUInt): PUTF8Char;
/// fast add text conversion of 0-999 integer value into a given buffer
// - warning: it won't check that Value is in 0-999 range
// - up to 4 bytes may be written to the buffer (including trailing #0)
function Append999ToBuffer(Buffer: PUTF8Char; Value: PtrUInt): PUTF8Char;
{$ifdef HASINLINE}inline;{$endif}
/// buffer-safe version of StrComp(), to be used with PUTF8Char/PAnsiChar
// - pure pascal StrComp() won't access the memory beyond the string, but this
// function is defined for compatibility with SSE 4.2 expectations
function StrCompFast(Str1, Str2: pointer): PtrInt;
{$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// fastest available version of StrComp(), to be used with PUTF8Char/PAnsiChar
// - won't use SSE4.2 instructions on supported CPUs by default, which may read
// some bytes beyond the s string, so should be avoided e.g. over memory mapped
// files - call explicitely StrCompSSE42() if you are confident on your input
var StrComp: function (Str1, Str2: pointer): PtrInt = StrCompFast;
/// pure pascal version of strspn(), to be used with PUTF8Char/PAnsiChar
// - please note that this optimized version may read up to 3 bytes beyond
// accept but never after s end, so is safe e.g. over memory mapped files
function strspnpas(s,accept: pointer): integer;
{$ifdef HASINLINE}inline;{$endif}
/// pure pascal version of strcspn(), to be used with PUTF8Char/PAnsiChar
// - please note that this optimized version may read up to 3 bytes beyond
// reject but never after s end, so is safe e.g. over memory mapped files
function strcspnpas(s,reject: pointer): integer;
{$ifdef HASINLINE}inline;{$endif}
/// fastest available version of strspn(), to be used with PUTF8Char/PAnsiChar
// - returns size of initial segment of s which appears in accept chars, e.g.
// ! strspn('abcdef','debca')=5
// - won't use SSE4.2 instructions on supported CPUs by default, which may read
// some bytes beyond the s string, so should be avoided e.g. over memory mapped
// files - call explicitely strspnsse42() if you are confident on your input
var strspn: function (s,accept: pointer): integer = strspnpas;
/// fastest available version of strcspn(), to be used with PUTF8Char/PAnsiChar
// - returns size of initial segment of s which doesn't appears in reject chars, e.g.
// ! strcspn('1234,6789',',')=4
// - won't use SSE4.2 instructions on supported CPUs by default, which may read
// some bytes beyond the s string, so should be avoided e.g. over memory mapped
// files - call explicitely strcspnsse42() if you are confident on your input
var strcspn: function (s,reject: pointer): integer = strcspnpas;
{$ifdef CPUINTEL}
{$ifndef ABSOLUTEPASCAL}
{$ifdef HASAESNI}
/// SSE 4.2 version of StrComp(), to be used with PUTF8Char/PAnsiChar
// - please note that this optimized version may read up to 15 bytes
// beyond the string; this is rarely a problem but it may generate protection
// violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system
// - could be used instead of StrComp() when you are confident about your
// Str1/Str2 input buffers, checking if cfSSE42 in CpuFeatures
function StrCompSSE42(Str1, Str2: pointer): PtrInt;
// - please note that this optimized version may read up to 15 bytes
// beyond the string; this is rarely a problem but it may generate protection
// violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system
// - could be used instead of StrLen() when you are confident about your
// S input buffers, checking if cfSSE42 in CpuFeatures
function StrLenSSE42(S: pointer): PtrInt;
{$endif HASAESNI}
/// SSE 4.2 version of strspn(), to be used with PUTF8Char/PAnsiChar
// - please note that this optimized version may read up to 15 bytes
// beyond the string; this is rarely a problem but it may generate protection
// violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system
// - could be used instead of strspn() when you are confident about your
// s/accept input buffers, checking if cfSSE42 in CpuFeatures
function strspnsse42(s,accept: pointer): integer;
/// SSE 4.2 version of strcspn(), to be used with PUTF8Char/PAnsiChar
// - please note that this optimized version may read up to 15 bytes
// beyond the string; this is rarely a problem but it may generate protection
// violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system
// - could be used instead of strcspn() when you are confident about your
// s/reject input buffers, checking if cfSSE42 in CpuFeatures
function strcspnsse42(s,reject: pointer): integer;
/// SSE 4.2 version of GetBitsCountPtrInt()
// - defined just for regression tests - call GetBitsCountPtrInt() instead
function GetBitsCountSSE42(value: PtrInt): PtrInt;
{$endif ABSOLUTEPASCAL}
{$endif CPUINTEL}
/// use our fast version of StrIComp(), to be used with PUTF8Char/PAnsiChar
function StrIComp(Str1, Str2: pointer): PtrInt;
{$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif}
/// slower version of StrLen(), but which will never read beyond the string
// - this version won't access the memory beyond the string, so may be
// preferred to StrLen(), when using e.g. memory mapped files or any memory
// protected buffer
function StrLenPas(S: pointer): PtrInt;
/// our fast version of StrLen(), to be used with PUTF8Char/PAnsiChar
// - if available, a fast SSE2 asm will be used on Intel/AMD CPUs
// - won't use SSE4.2 instructions on supported CPUs by default, which may read
// some bytes beyond the string, so should be avoided e.g. over memory mapped
// files - call explicitely StrLenSSE42() if you are confident on your input
var StrLen: function(S: pointer): PtrInt = StrLenPas;
{$ifdef ABSOLUTEPASCAL}
var FillcharFast: procedure(var Dest; count: PtrInt; Value: byte) = system.FillChar;
var MoveFast: procedure(const Source; var Dest; Count: PtrInt) = system.Move;
{$else}
{$ifdef CPUX64} // will define its own self-dispatched SSE2/AVX functions
type
/// cpuERMS is slightly slower than cpuAVX so is not available by default
TX64CpuFeatures = set of(cpuAVX, cpuAVX2 {$ifdef WITH_ERMS}, cpuERMS{$endif});
var
/// internal flags used by FillCharFast - easier from asm that CpuFeatures
CPUIDX64: TX64CpuFeatures;
procedure FillcharFast(var dst; cnt: PtrInt; value: byte);
procedure MoveFast(const src; var dst; cnt: PtrInt);
{$else}
/// our fast version of FillChar()
// - on Intel i386/x86_64, will use fast SSE2/ERMS instructions (if available),
// or optimized X87 assembly implementation for older CPUs
// - on non-Intel CPUs, it will fallback to the default RTL FillChar()
// - note: Delphi x86_64 is far from efficient: even ERMS was wrongly
// introduced in latest updates
var FillcharFast: procedure(var Dest; count: PtrInt; Value: byte);
/// our fast version of move()
// - on Delphi Intel i386/x86_64, will use fast SSE2 instructions (if available),
// or optimized X87 assembly implementation for older CPUs
// - on non-Intel CPUs, it will fallback to the default RTL Move()
var MoveFast: procedure(const Source; var Dest; Count: PtrInt);
{$endif CPUX64}
{$endif ABSOLUTEPASCAL}
/// an alternative Move() function tuned for small unaligned counts
// - warning: expects Count>0 and Source/Dest not nil
// - warning: doesn't support buffers overlapping
procedure MoveSmall(Source, Dest: Pointer; Count: PtrUInt);
{$ifdef HASINLINE}inline;{$endif}
/// our fast version of StrLen(), to be used with PWideChar
function StrLenW(S: PWideChar): PtrInt;
/// use our fast version of StrComp(), to be used with PWideChar
function StrCompW(Str1, Str2: PWideChar): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
/// use our fast version of StrCompL(), to be used with PUTF8Char
function StrCompL(P1,P2: PUTF8Char; L, Default: Integer): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
/// use our fast version of StrCompIL(), to be used with PUTF8Char
function StrCompIL(P1,P2: PUTF8Char; L: Integer; Default: Integer=0): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
{$ifdef USENORMTOUPPER}
{$ifdef OWNNORMTOUPPER}
type
TNormTable = packed array[AnsiChar] of AnsiChar;
PNormTable = ^TNormTable;
TNormTableByte = packed array[byte] of byte;
PNormTableByte = ^TNormTableByte;
var
/// the NormToUpper[] array is defined in our Enhanced RTL: define it now
// if it was not installed
// - handle 8 bit upper chars as in WinAnsi / code page 1252 (e.g. accents)
NormToUpper: TNormTable;
NormToUpperByte: TNormTableByte absolute NormToUpper;
/// the NormToLower[] array is defined in our Enhanced RTL: define it now
// if it was not installed
// - handle 8 bit upper chars as in WinAnsi / code page 1252 (e.g. accents)
NormToLower: TNormTable;
NormToLowerByte: TNormTableByte absolute NormToLower;
{$endif}
{$else}
{$undef OWNNORMTOUPPER}
{$endif}
var
/// this table will convert 'a'..'z' into 'A'..'Z'
// - so it will work with UTF-8 without decoding, whereas NormToUpper[] expects
// WinAnsi encoding
NormToUpperAnsi7: TNormTable;
NormToUpperAnsi7Byte: TNormTableByte absolute NormToUpperAnsi7;
/// case sensitive NormToUpper[]/NormToLower[]-like table
// - i.e. NormToNorm[c] = c
NormToNorm: TNormTable;
NormToNormByte: TNormTableByte absolute NormToNorm;
/// get the signed 32-bit integer value stored in P^
// - we use the PtrInt result type, even if expected to be 32-bit, to use
// native CPU register size (don't want any 32-bit overflow here)
// - will end parsing when P^ does not contain any number (e.g. it reaches any
// ending #0 char)
function GetInteger(P: PUTF8Char): PtrInt; overload;
/// get the signed 32-bit integer value stored in P^..PEnd^
// - will end parsing when P^ does not contain any number (e.g. it reaches any
// ending #0 char), or when P reached PEnd (avoiding any buffer overflow)
function GetInteger(P,PEnd: PUTF8Char): PtrInt; overload;
/// get the signed 32-bit integer value stored in P^
// - if P if nil or not start with a valid numerical value, returns Default
function GetIntegerDef(P: PUTF8Char; Default: PtrInt): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
/// get the signed 32-bit integer value stored in P^
// - this version return 0 in err if no error occured, and 1 if an invalid
// character was found, not its exact index as for the val() function
function GetInteger(P: PUTF8Char; var err: integer): PtrInt; overload;
/// get the unsigned 32-bit integer value stored in P^
// - we use the PtrUInt result type, even if expected to be 32-bit, to use
// native CPU register size (don't want any 32-bit overflow here)
function GetCardinal(P: PUTF8Char): PtrUInt;
/// get the unsigned 32-bit integer value stored in P^
// - if P if nil or not start with a valid numerical value, returns Default
function GetCardinalDef(P: PUTF8Char; Default: PtrUInt): PtrUInt;
/// get the unsigned 32-bit integer value stored as Unicode string in P^
function GetCardinalW(P: PWideChar): PtrUInt;
/// get a boolean value stored as true/false text in P^
// - would also recognize any non 0 integer as true
function GetBoolean(P: PUTF8Char): boolean;
/// get the 64-bit integer value stored in P^
function GetInt64(P: PUTF8Char): Int64; overload;
{$ifdef HASINLINE}inline;{$endif}
/// get the 64-bit integer value stored in P^
// - if P if nil or not start with a valid numerical value, returns Default
function GetInt64Def(P: PUTF8Char; const Default: Int64): Int64;
/// get the 64-bit signed integer value stored in P^
procedure SetInt64(P: PUTF8Char; var result: Int64);
{$ifdef CPU64}inline;{$endif}
/// get the 64-bit unsigned integer value stored in P^
procedure SetQWord(P: PUTF8Char; var result: QWord);
{$ifdef CPU64}inline;{$endif}
/// get the 64-bit signed integer value stored in P^
// - set the err content to the index of any faulty character, 0 if conversion
// was successful (same as the standard val function)
function GetInt64(P: PUTF8Char; var err: integer): Int64; overload;
{$ifdef CPU64}inline;{$endif}
/// get the 64-bit unsigned integer value stored in P^
// - set the err content to the index of any faulty character, 0 if conversion
// was successful (same as the standard val function)
function GetQWord(P: PUTF8Char; var err: integer): QWord;
/// get the extended floating point value stored in P^
// - set the err content to the index of any faulty character, 0 if conversion
// was successful (same as the standard val function)
function GetExtended(P: PUTF8Char; out err: integer): TSynExtended; overload;
/// get the extended floating point value stored in P^
// - this overloaded version returns 0 as a result if the content of P is invalid
function GetExtended(P: PUTF8Char): TSynExtended; overload;
{$ifdef HASINLINE}inline;{$endif}
/// copy a floating-point text buffer with proper correction and validation
// - will correct on the fly '.5' -> '0.5' and '-.5' -> '-0.5'
// - will end not only on #0 but on any char not matching 1[.2[e[-]3]] pattern
// - is used when the input comes from a third-party source with no regular
// output, e.g. a database driver, via TTextWriter.AddFloatStr
function FloatStrCopy(s, d: PUTF8Char): PUTF8Char;
/// get the WideChar stored in P^ (decode UTF-8 if necessary)
// - any surrogate (UCS4>$ffff) will be returned as '?'
function GetUTF8Char(P: PUTF8Char): cardinal;
{$ifdef HASINLINE}inline;{$endif}
/// get the UCS4 char stored in P^ (decode UTF-8 if necessary)
function NextUTF8UCS4(var P: PUTF8Char): cardinal;
{$ifdef HASINLINE}inline;{$endif}
/// get the signed 32-bit integer value stored in a RawUTF8 string
// - we use the PtrInt result type, even if expected to be 32-bit, to use
// native CPU register size (don't want any 32-bit overflow here)
function UTF8ToInteger(const value: RawUTF8; Default: PtrInt=0): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// get and check range of a signed 32-bit integer stored in a RawUTF8 string
// - we use the PtrInt result type, even if expected to be 32-bit, to use
// native CPU register size (don't want any 32-bit overflow here)
function UTF8ToInteger(const value: RawUTF8; Min,max: PtrInt; Default: PtrInt=0): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// get the signed 32-bit integer value stored in a RawUTF8 string
// - returns TRUE if the supplied text was successfully converted into an integer
function ToInteger(const text: RawUTF8; out value: integer): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// get the unsigned 32-bit cardinal value stored in a RawUTF8 string
// - returns TRUE if the supplied text was successfully converted into a cardinal
function ToCardinal(const text: RawUTF8; out value: cardinal; minimal: cardinal=0): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// get the signed 64-bit integer value stored in a RawUTF8 string
// - returns TRUE if the supplied text was successfully converted into an Int64
function ToInt64(const text: RawUTF8; out value: Int64): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// get a 64-bit floating-point value stored in a RawUTF8 string
// - returns TRUE if the supplied text was successfully converted into a double
function ToDouble(const text: RawUTF8; out value: double): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// get the signed 64-bit integer value stored in a RawUTF8 string
// - returns the default value if the supplied text was not successfully
// converted into an Int64
function UTF8ToInt64(const text: RawUTF8; const default: Int64=0): Int64;
/// encode a string to be compatible with URI encoding
function UrlEncode(const svar: RawUTF8): RawUTF8; overload;
/// encode a string to be compatible with URI encoding
function UrlEncode(Text: PUTF8Char): RawUTF8; overload;
/// encode supplied parameters to be compatible with URI encoding
// - parameters must be supplied two by two, as Name,Value pairs, e.g.
// ! url := UrlEncode(['select','*','where','ID=12','offset',23,'object',aObject]);
// - parameters names should be plain ASCII-7 RFC compatible identifiers
// (0..9a..zA..Z_.~), otherwise their values are skipped
// - parameters values can be either textual, integer or extended, or any TObject
// - TObject serialization into UTF-8 will be processed by the ObjectToJSON()
// function
function UrlEncode(const NameValuePairs: array of const): RawUTF8; overload;
/// encode a JSON object UTF-8 buffer into URI parameters
// - you can specify property names to ignore during the object decoding
// - you can omit the leading query delimiter ('?') by setting IncludeQueryDelimiter=false
// - warning: the ParametersJSON input buffer will be modified in-place
function UrlEncodeJsonObject(const URIName: RawUTF8; ParametersJSON: PUTF8Char;
const PropNamesToIgnore: array of RawUTF8; IncludeQueryDelimiter: Boolean=true): RawUTF8; overload;
/// encode a JSON object UTF-8 buffer into URI parameters
// - you can specify property names to ignore during the object decoding
// - you can omit the leading query delimiter ('?') by setting IncludeQueryDelimiter=false
// - overloaded function which will make a copy of the input JSON before parsing
function UrlEncodeJsonObject(const URIName, ParametersJSON: RawUTF8;
const PropNamesToIgnore: array of RawUTF8; IncludeQueryDelimiter: Boolean=true): RawUTF8; overload;
/// decode a string compatible with URI encoding into its original value
// - you can specify the decoding range (as in copy(s,i,len) function)
function UrlDecode(const s: RawUTF8; i: PtrInt=1; len: PtrInt=-1): RawUTF8; overload;
/// decode a string compatible with URI encoding into its original value
function UrlDecode(U: PUTF8Char): RawUTF8; overload;
/// decode a specified parameter compatible with URI encoding into its original
// textual value
// - UrlDecodeValue('select=%2A&where=LastName%3D%27M%C3%B4net%27','SELECT=',V,@Next)
// will return Next^='where=...' and V='*'
// - if Upper is not found, Value is not modified, and result is FALSE
// - if Upper is found, Value is modified with the supplied content, and result is TRUE
function UrlDecodeValue(U: PUTF8Char; const Upper: RawUTF8; var Value: RawUTF8;
Next: PPUTF8Char=nil): boolean;
/// decode a specified parameter compatible with URI encoding into its original
// integer numerical value
// - UrlDecodeInteger('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next)
// will return Next^='where=...' and O=20
// - if Upper is not found, Value is not modified, and result is FALSE
// - if Upper is found, Value is modified with the supplied content, and result is TRUE
function UrlDecodeInteger(U: PUTF8Char; const Upper: RawUTF8; var Value: integer;
Next: PPUTF8Char=nil): boolean;
/// decode a specified parameter compatible with URI encoding into its original
// cardinal numerical value
// - UrlDecodeCardinal('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next)
// will return Next^='where=...' and O=20
// - if Upper is not found, Value is not modified, and result is FALSE
// - if Upper is found, Value is modified with the supplied content, and result is TRUE
function UrlDecodeCardinal(U: PUTF8Char; const Upper: RawUTF8; var Value: Cardinal;
Next: PPUTF8Char=nil): boolean;
/// decode a specified parameter compatible with URI encoding into its original
// Int64 numerical value
// - UrlDecodeInt64('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next)
// will return Next^='where=...' and O=20
// - if Upper is not found, Value is not modified, and result is FALSE
// - if Upper is found, Value is modified with the supplied content, and result is TRUE
function UrlDecodeInt64(U: PUTF8Char; const Upper: RawUTF8; var Value: Int64;
Next: PPUTF8Char=nil): boolean;
/// decode a specified parameter compatible with URI encoding into its original
// floating-point value
// - UrlDecodeExtended('price=20.45&where=LastName%3D%27M%C3%B4net%27','PRICE=',P,@Next)
// will return Next^='where=...' and P=20.45
// - if Upper is not found, Value is not modified, and result is FALSE
// - if Upper is found, Value is modified with the supplied content, and result is TRUE
function UrlDecodeExtended(U: PUTF8Char; const Upper: RawUTF8; var Value: TSynExtended;
Next: PPUTF8Char=nil): boolean;
/// decode a specified parameter compatible with URI encoding into its original
// floating-point value
// - UrlDecodeDouble('price=20.45&where=LastName%3D%27M%C3%B4net%27','PRICE=',P,@Next)
// will return Next^='where=...' and P=20.45
// - if Upper is not found, Value is not modified, and result is FALSE
// - if Upper is found, Value is modified with the supplied content, and result is TRUE
function UrlDecodeDouble(U: PUTF8Char; const Upper: RawUTF8; var Value: double;
Next: PPUTF8Char=nil): boolean;
/// returns TRUE if all supplied parameters do exist in the URI encoded text
// - CSVNames parameter shall provide as a CSV list of names
// - e.g. UrlDecodeNeedParameters('price=20.45&where=LastName%3D','price,where')
// will return TRUE
function UrlDecodeNeedParameters(U, CSVNames: PUTF8Char): boolean;
/// decode the next Name=Value&.... pair from input URI
// - Name is returned directly (should be plain ASCII 7 bit text)
// - Value is returned after URI decoding (from %.. patterns)
// - if a pair is decoded, return a PUTF8Char pointer to the next pair in
// the input buffer, or points to #0 if all content has been processed
// - if a pair is not decoded, return nil
function UrlDecodeNextNameValue(U: PUTF8Char; var Name,Value: RawUTF8): PUTF8Char;
/// decode a URI-encoded Value from an input buffer
// - decoded value is set in Value out variable
// - returns a pointer just after the decoded value (may points e.g. to
// #0 or '&') - it is up to the caller to continue the process or not
function UrlDecodeNextValue(U: PUTF8Char; out Value: RawUTF8): PUTF8Char;
/// decode a URI-encoded Name from an input buffer
// - decoded value is set in Name out variable
// - returns a pointer just after the decoded name, after the '='
// - returns nil if there was no name=... pattern in U
function UrlDecodeNextName(U: PUTF8Char; out Name: RawUTF8): PUTF8Char;
/// checks if the supplied UTF-8 text don't need URI encoding
// - returns TRUE if all its chars are non-void plain ASCII-7 RFC compatible
// identifiers (0..9a..zA..Z-_.~)
function IsUrlValid(P: PUTF8Char): boolean;
/// checks if the supplied UTF-8 text values don't need URI encoding
// - returns TRUE if all its chars of all strings are non-void plain ASCII-7 RFC
// compatible identifiers (0..9a..zA..Z-_.~)
function AreUrlValid(const Url: array of RawUTF8): boolean;
/// ensure the supplied URI contains a trailing '/' charater
function IncludeTrailingURIDelimiter(const URI: RawByteString): RawByteString;
/// encode name/value pairs into CSV/INI raw format
function CSVEncode(const NameValuePairs: array of const;
const KeySeparator: RawUTF8='='; const ValueSeparator: RawUTF8=#13#10): RawUTF8;
/// find a given name in name/value pairs, and returns the value as RawUTF8
function ArrayOfConstValueAsText(const NameValuePairs: array of const;
const aName: RawUTF8): RawUTF8;
/// returns TRUE if the given text buffer contains a..z,A..Z,0..9,_ characters
// - should match most usual property names values or other identifier names
// in the business logic source code
// - i.e. can be tested via IdemPropName*() functions, and the MongoDB-like
// extended JSON syntax as generated by dvoSerializeAsExtendedJson
// - first char must be alphabetical or '_', following chars can be
// alphanumerical or '_'
function PropNameValid(P: PUTF8Char): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// returns TRUE if the given text buffers contains A..Z,0..9,_ characters
// - use it with property names values (i.e. only including A..Z,0..9,_ chars)
// - this function won't check the first char the same way than PropNameValid()
function PropNamesValid(const Values: array of RawUTF8): boolean;
type
/// kind of character used from JSON_CHARS[] for efficient JSON parsing
TJsonChar = set of (jcJsonIdentifierFirstChar, jcJsonIdentifier,
jcEndOfJSONField, jcEndOfJSONFieldOr0, jcEndOfJSONValueField,
jcDigitChar, jcDigitFirstChar, jcDigitFloatChar);
/// defines a branch-less table used for JSON parsing
TJsonCharSet = array[AnsiChar] of TJsonChar;
PJsonCharSet = ^TJsonCharSet;
var
/// branch-less table used for JSON parsing
JSON_CHARS: TJsonCharSet;
/// returns TRUE if the given text buffer contains simple characters as
// recognized by JSON extended syntax
// - follow GetJSONPropName and GotoNextJSONObjectOrArray expectations
function JsonPropNameValid(P: PUTF8Char): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// returns TRUE if the given text buffers would be escaped when written as JSON
// - e.g. if contains " or \ characters, as defined by
// http://www.ietf.org/rfc/rfc4627.txt
function NeedsJsonEscape(const Text: RawUTF8): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// returns TRUE if the given text buffers would be escaped when written as JSON
// - e.g. if contains " or \ characters, as defined by
// http://www.ietf.org/rfc/rfc4627.txt
function NeedsJsonEscape(P: PUTF8Char): boolean; overload;
/// returns TRUE if the given text buffers would be escaped when written as JSON
// - e.g. if contains " or \ characters, as defined by
// http://www.ietf.org/rfc/rfc4627.txt
function NeedsJsonEscape(P: PUTF8Char; PLen: integer): boolean; overload;
/// case insensitive comparison of ASCII identifiers
// - use it with property names values (i.e. only including A..Z,0..9,_ chars)
function IdemPropName(const P1,P2: shortstring): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// case insensitive comparison of ASCII identifiers
// - use it with property names values (i.e. only including A..Z,0..9,_ chars)
// - this version expects P2 to be a PAnsiChar with a specified length
function IdemPropName(const P1: shortstring; P2: PUTF8Char; P2Len: PtrInt): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// case insensitive comparison of ASCII identifiers
// - use it with property names values (i.e. only including A..Z,0..9,_ chars)
// - this version expects P1 and P2 to be a PAnsiChar with specified lengths
function IdemPropName(P1,P2: PUTF8Char; P1Len,P2Len: PtrInt): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// case insensitive comparison of ASCII identifiers
// - use it with property names values (i.e. only including A..Z,0..9,_ chars)
// - this version expects P2 to be a PAnsiChar with specified length
function IdemPropNameU(const P1: RawUTF8; P2: PUTF8Char; P2Len: PtrInt): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// case insensitive comparison of ASCII identifiers of same length
// - use it with property names values (i.e. only including A..Z,0..9,_ chars)
// - this version expects P1 and P2 to be a PAnsiChar with an already checked
// identical length, so may be used for a faster process, e.g. in a loop
// - if P1 and P2 are RawUTF8, you should better call overloaded function
// IdemPropNameU(const P1,P2: RawUTF8), which would be slightly faster by
// using the length stored before the actual text buffer of each RawUTF8
function IdemPropNameUSameLen(P1,P2: PUTF8Char; P1P2Len: PtrInt): boolean;
{$ifndef ANDROID}{$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif}{$endif}
/// case insensitive comparison of ASCII identifiers
// - use it with property names values (i.e. only including A..Z,0..9,_ chars)
function IdemPropNameU(const P1,P2: RawUTF8): boolean; overload;
{$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// returns true if the beginning of p^ is the same as up^
// - ignore case - up^ must be already Upper
// - chars are compared as 7 bit Ansi only (no accentuated characters): but when
// you only need to search for field names e.g. IdemPChar() is prefered, because
// it'll be faster than IdemPCharU(), if UTF-8 decoding is not mandatory
// - if p is nil, will return FALSE
// - if up is nil, will return TRUE
function IdemPChar(p: PUTF8Char; up: PAnsiChar): boolean;
{$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// returns true if the beginning of p^ is the same as up^, ignoring white spaces
// - ignore case - up^ must be already Upper
// - any white space in the input p^ buffer is just ignored
// - chars are compared as 7 bit Ansi only (no accentuated characters): but when
// you only need to search for field names e.g. IdemPChar() is prefered, because
// it'll be faster than IdemPCharU(), if UTF-8 decoding is not mandatory
// - if p is nil, will return FALSE
// - if up is nil, will return TRUE
function IdemPCharWithoutWhiteSpace(p: PUTF8Char; up: PAnsiChar): boolean;
/// returns the index of a matching beginning of p^ in upArray[]
// - returns -1 if no item matched
// - ignore case - upArray^ must be already Upper
// - chars are compared as 7 bit Ansi only (no accentuated characters)
// - warning: this function expects upArray[] items to have AT LEAST TWO
// CHARS (it will use a fast comparison of initial 2 bytes)
function IdemPCharArray(p: PUTF8Char; const upArray: array of PAnsiChar): integer; overload;
/// returns the index of a matching beginning of p^ in upArray two characters
// - returns -1 if no item matched
// - ignore case - upArray^ must be already Upper
// - chars are compared as 7 bit Ansi only (no accentuated characters)
function IdemPCharArray(p: PUTF8Char; const upArrayBy2Chars: RawUTF8): integer; overload;
{$ifdef HASINLINE}inline;{$endif}
/// returns true if the beginning of p^ is the same as up^
// - ignore case - up^ must be already Upper
// - this version will decode the UTF-8 content before using NormToUpper[], so
// it will be slower than the IdemPChar() function above, but will handle
// WinAnsi accentuated characters (e.g. 'e' acute will be matched as 'E')
function IdemPCharU(p, up: PUTF8Char): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// returns true if the beginning of p^ is same as up^
// - ignore case - up^ must be already Upper
// - this version expects p^ to point to an Unicode char array
function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean;
/// check matching ending of p^ in upText
// - returns true if the item matched
// - ignore case - upText^ must be already Upper
// - chars are compared as 7 bit Ansi only (no accentuated characters)
function EndWith(const text, upText: RawUTF8): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// returns the index of a matching ending of p^ in upArray[]
// - returns -1 if no item matched
// - ignore case - upArray^ must be already Upper
// - chars are compared as 7 bit Ansi only (no accentuated characters)
function EndWithArray(const text: RawUTF8; const upArray: array of RawUTF8): integer;
/// returns true if the file name extension contained in p^ is the same same as extup^
// - ignore case - extup^ must be already Upper
// - chars are compared as WinAnsi (codepage 1252), not as UTF-8
// - could be used e.g. like IdemFileExt(aFileName,'.JP');
function IdemFileExt(p: PUTF8Char; extup: PAnsiChar; sepChar: AnsiChar='.'): Boolean;
/// returns matching file name extension index as extup^
// - ignore case - extup[] must be already Upper
// - chars are compared as WinAnsi (codepage 1252), not as UTF-8
// - could be used e.g. like IdemFileExts(aFileName,['.PAS','.INC']);
function IdemFileExts(p: PUTF8Char; const extup: array of PAnsiChar;
sepChar: AnsiChar='.'): integer;
/// internal function, used to retrieve a UCS4 char (>127) from UTF-8
// - not to be called directly, but from inlined higher-level functions
// - here U^ shall be always >= #80
// - typical use is as such:
// ! ch := ord(P^);
// ! if ch and $80=0 then
// ! inc(P) else
// ! ch := GetHighUTF8UCS4(P);
function GetHighUTF8UCS4(var U: PUTF8Char): PtrUInt;
/// retrieve the next UCS4 value stored in U, then update the U pointer
// - this function will decode the UTF-8 content before using NormToUpper[]
// - will return '?' if the UCS4 value is higher than #255: so use this function
// only if you need to deal with ASCII characters (e.g. it's used for Soundex
// and for ContainsUTF8 function)
function GetNextUTF8Upper(var U: PUTF8Char): PtrUInt;
{$ifdef HASINLINE}inline;{$endif}
/// points to the beginning of the next word stored in U
// - returns nil if reached the end of U (i.e. #0 char)
// - here a "word" is a Win-Ansi word, i.e. '0'..'9', 'A'..'Z'
function FindNextUTF8WordBegin(U: PUTF8Char): PUTF8Char;
/// return true if up^ is contained inside the UTF-8 buffer p^
// - search up^ at the beginning of every UTF-8 word (aka in Soundex)
// - here a "word" is a Win-Ansi word, i.e. '0'..'9', 'A'..'Z'
// - up^ must be already Upper
function ContainsUTF8(p, up: PUTF8Char): boolean;
/// returns TRUE if the supplied uppercased text is contained in the text buffer
function GetLineContains(p,pEnd, up: PUTF8Char): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// copy source into a 256 chars dest^ buffer with 7 bits upper case conversion
// - used internally for short keys match or case-insensitive hash
// - returns final dest pointer
// - will copy up to 255 AnsiChar (expect the dest buffer to be defined e.g. as
// array[byte] of AnsiChar on the caller stack)
function UpperCopy255(dest: PAnsiChar; const source: RawUTF8): PAnsiChar; overload;
{$ifdef HASINLINE}inline;{$endif}
/// copy source^ into a 256 chars dest^ buffer with 7 bits upper case conversion
// - used internally for short keys match or case-insensitive hash
// - returns final dest pointer
// - will copy up to 255 AnsiChar (expect the dest buffer to be defined e.g. as
// array[byte] of AnsiChar on the caller stack)
// - won't use SSE4.2 instructions on supported CPUs by default, which may read
// some bytes beyond the s string, so should be avoided e.g. over memory mapped
// files - call explicitely UpperCopy255BufSSE42() if you are confident on your input
var UpperCopy255Buf: function(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar;
/// copy source^ into a 256 chars dest^ buffer with 7 bits upper case conversion
// - used internally for short keys match or case-insensitive hash
// - this version is written in optimized pascal
// - you should not have to call this function, but rely on UpperCopy255Buf()
// - returns final dest pointer
// - will copy up to 255 AnsiChar (expect the dest buffer to be defined e.g. as
// array[byte] of AnsiChar on the caller stack)
function UpperCopy255BufPas(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar;
{$ifndef PUREPASCAL}
{$ifndef DELPHI5OROLDER}
/// SSE 4.2 version of UpperCopy255Buf()
// - copy source^ into a 256 chars dest^ buffer with 7 bits upper case conversion
// - please note that this optimized version may read up to 15 bytes
// beyond the string; this is rarely a problem but it may generate protection
// violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system
// - could be used instead of UpperCopy255Buf() when you are confident about your
// dest/source input buffers, checking if cfSSE42 in CpuFeatures
function UpperCopy255BufSSE42(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar;
{$endif DELPHI5OROLDER}
{$endif PUREPASCAL}
/// copy source into dest^ with WinAnsi 8 bits upper case conversion
// - used internally for short keys match or case-insensitive hash
// - returns final dest pointer
// - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of
// AnsiChar)
function UpperCopyWin255(dest: PWinAnsiChar; const source: RawUTF8): PWinAnsiChar;
/// copy WideChar source into dest^ with upper case conversion
// - used internally for short keys match or case-insensitive hash
// - returns final dest pointer
// - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of
// AnsiChar)
function UpperCopy255W(dest: PAnsiChar; const source: SynUnicode): PAnsiChar; overload;
/// copy WideChar source into dest^ with upper case conversion
// - used internally for short keys match or case-insensitive hash
// - returns final dest pointer
// - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of
// AnsiChar)
function UpperCopy255W(dest: PAnsiChar; source: PWideChar; L: integer): PAnsiChar; overload;
/// copy source into dest^ with 7 bits upper case conversion
// - returns final dest pointer
// - will copy up to the source buffer end: so Dest^ should be big enough -
// which will the case e.g. if Dest := pointer(source)
function UpperCopy(dest: PAnsiChar; const source: RawUTF8): PAnsiChar;
/// copy source into dest^ with 7 bits upper case conversion
// - returns final dest pointer
// - this special version expect source to be a shortstring
function UpperCopyShort(dest: PAnsiChar; const source: shortstring): PAnsiChar;
{$ifdef USENORMTOUPPER}
/// fast UTF-8 comparison using the NormToUpper[] array for all 8 bits values
// - this version expects u1 and u2 to be zero-terminated
// - this version will decode each UTF-8 glyph before using NormToUpper[]
// - current implementation handles UTF-16 surrogates
function UTF8IComp(u1, u2: PUTF8Char): PtrInt;
/// copy WideChar source into dest^ with upper case conversion, using the
// NormToUpper[] array for all 8 bits values, encoding the result as UTF-8
// - returns final dest pointer
// - current implementation handles UTF-16 surrogates
function UTF8UpperCopy(Dest, Source: PUTF8Char; SourceChars: Cardinal): PUTF8Char;
/// copy WideChar source into dest^ with upper case conversion, using the
// NormToUpper[] array for all 8 bits values, encoding the result as UTF-8
// - returns final dest pointer
// - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of
// AnsiChar), with UTF-8 encoding
function UTF8UpperCopy255(dest: PAnsiChar; const source: RawUTF8): PUTF8Char;
{$ifdef HASINLINE}inline;{$endif}
/// fast UTF-8 comparison using the NormToUpper[] array for all 8 bits values
// - this version expects u1 and u2 not to be necessary zero-terminated, but
// uses L1 and L2 as length for u1 and u2 respectively
// - use this function for SQLite3 collation (TSQLCollateFunc)
// - this version will decode the UTF-8 content before using NormToUpper[]
// - current implementation handles UTF-16 surrogates
function UTF8ILComp(u1, u2: PUTF8Char; L1,L2: cardinal): PtrInt;
/// fast case-insensitive Unicode comparison
// - use the NormToUpperAnsi7Byte[] array, i.e. compare 'a'..'z' as 'A'..'Z'
// - this version expects u1 and u2 to be zero-terminated
function AnsiICompW(u1, u2: PWideChar): PtrInt;
/// SameText() overloaded function with proper UTF-8 decoding
// - fast version using NormToUpper[] array for all Win-Ansi characters
// - this version will decode each UTF-8 glyph before using NormToUpper[]
// - current implementation handles UTF-16 surrogates as UTF8IComp()
function SameTextU(const S1, S2: RawUTF8): Boolean;
{$ifdef HASINLINE}inline;{$endif}
/// fast conversion of the supplied text into 8 bit uppercase
// - this will not only convert 'a'..'z' into 'A'..'Z', but also accentuated
// latin characters ('e' acute into 'E' e.g.), using NormToUpper[] array
// - it will therefore decode the supplied UTF-8 content to handle more than
// 7 bit of ascii characters (so this function is dedicated to WinAnsi code page
// 1252 characters set)
function UpperCaseU(const S: RawUTF8): RawUTF8;
/// fast conversion of the supplied text into 8 bit lowercase
// - this will not only convert 'A'..'Z' into 'a'..'z', but also accentuated
// latin characters ('E' acute into 'e' e.g.), using NormToLower[] array
// - it will therefore decode the supplied UTF-8 content to handle more than
// 7 bit of ascii characters
function LowerCaseU(const S: RawUTF8): RawUTF8;
/// fast conversion of the supplied text into 8 bit case sensitivity
// - convert the text in-place, returns the resulting length
// - it will decode the supplied UTF-8 content to handle more than 7 bit
// of ascii characters during the conversion (leaving not WinAnsi characters
// untouched)
// - will not set the last char to #0 (caller must do that if necessary)
function ConvertCaseUTF8(P: PUTF8Char; const Table: TNormTableByte): PtrInt;
{$endif USENORMTOUPPER}
/// check if the supplied text has some case-insentitive 'a'..'z','A'..'Z' chars
// - will therefore be correct with true UTF-8 content, but only for 7 bit
function IsCaseSensitive(const S: RawUTF8): boolean; overload;
/// check if the supplied text has some case-insentitive 'a'..'z','A'..'Z' chars
// - will therefore be correct with true UTF-8 content, but only for 7 bit
function IsCaseSensitive(P: PUTF8Char; PLen: PtrInt): boolean; overload;
/// fast conversion of the supplied text into uppercase
// - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and
// will therefore be correct with true UTF-8 content, but only for 7 bit
function UpperCase(const S: RawUTF8): RawUTF8;
/// fast conversion of the supplied text into uppercase
// - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and
// will therefore be correct with true UTF-8 content, but only for 7 bit
procedure UpperCaseCopy(Text: PUTF8Char; Len: PtrInt; var result: RawUTF8); overload;
/// fast conversion of the supplied text into uppercase
// - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and
// will therefore be correct with true UTF-8 content, but only for 7 bit
procedure UpperCaseCopy(const Source: RawUTF8; var Dest: RawUTF8); overload;
/// fast in-place conversion of the supplied variable text into uppercase
// - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and
// will therefore be correct with true UTF-8 content, but only for 7 bit
procedure UpperCaseSelf(var S: RawUTF8);
/// fast conversion of the supplied text into lowercase
// - this will only convert 'A'..'Z' into 'a'..'z' (no NormToLower use), and
// will therefore be correct with true UTF-8 content
function LowerCase(const S: RawUTF8): RawUTF8;
/// fast conversion of the supplied text into lowercase
// - this will only convert 'A'..'Z' into 'a'..'z' (no NormToLower use), and
// will therefore be correct with true UTF-8 content
procedure LowerCaseCopy(Text: PUTF8Char; Len: PtrInt; var result: RawUTF8);
/// fast in-place conversion of the supplied variable text into lowercase
// - this will only convert 'A'..'Z' into 'a'..'z' (no NormToLower use), and
// will therefore be correct with true UTF-8 content, but only for 7 bit
procedure LowerCaseSelf(var S: RawUTF8);
/// accurate conversion of the supplied UTF-8 content into the corresponding
// upper-case Unicode characters
// - this version will use the Operating System API, and will therefore be
// much slower than UpperCase/UpperCaseU versions, but will handle all
// kind of unicode characters
function UpperCaseUnicode(const S: RawUTF8): RawUTF8;
/// accurate conversion of the supplied UTF-8 content into the corresponding
// lower-case Unicode characters
// - this version will use the Operating System API, and will therefore be
// much slower than LowerCase/LowerCaseU versions, but will handle all
// kind of unicode characters
function LowerCaseUnicode(const S: RawUTF8): RawUTF8;
/// trims leading whitespace characters from the string by removing
// new line, space, and tab characters
function TrimLeft(const S: RawUTF8): RawUTF8;
/// trims trailing whitespace characters from the string by removing trailing
// newline, space, and tab characters
function TrimRight(const S: RawUTF8): RawUTF8;
/// single-allocation (therefore faster) alternative to Trim(copy())
procedure TrimCopy(const S: RawUTF8; start,count: PtrInt;
var result: RawUTF8);
/// fast WinAnsi comparison using the NormToUpper[] array for all 8 bits values
function AnsiIComp(Str1, Str2: pointer): PtrInt;
{$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif}
/// extract a line from source array of chars
// - next will contain the beginning of next line, or nil if source if ended
function GetNextLine(source: PUTF8Char; out next: PUTF8Char; andtrim: boolean=false): RawUTF8;
{$ifdef UNICODE}
/// extract a line from source array of chars
// - next will contain the beginning of next line, or nil if source if ended
// - this special version expect UnicodeString pointers, and return an UnicodeString
function GetNextLineW(source: PWideChar; out next: PWideChar): string;
/// find the Value of UpperName in P, till end of current section
// - expect UpperName as 'NAME='
// - this special version expect UnicodeString pointer, and return a VCL string
function FindIniNameValueW(P: PWideChar; UpperName: PUTF8Char): string;
/// find a Name= Value in a [Section] of a INI Unicode Content
// - this function scans the Content memory buffer, and is
// therefore very fast (no temporary TMemIniFile is created)
// - if Section equals '', find the Name= value before any [Section]
function FindIniEntryW(const Content: string; const Section, Name: RawUTF8): string;
{$endif UNICODE}
{$ifdef PUREPASCAL}
{$ifdef HASINLINE}
function PosExPas(pSub, p: PUTF8Char; Offset: PtrUInt): PtrInt;
function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt=1): PtrInt; inline;
{$else}
var PosEx: function(const SubStr, S: RawUTF8; Offset: PtrUInt=1): PtrInt;
{$endif}
{$else}
/// faster RawUTF8 Equivalent of standard StrUtils.PosEx
function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt=1): integer;
{$endif PUREPASCAL}
/// our own PosEx() function dedicated to VCL string process
// - Delphi XE or older don't support Pos() with an Offset
var PosExString: function(const SubStr, S: string; Offset: PtrUInt=1): PtrInt;
/// optimized version of PosEx() with search text as one AnsiChar
function PosExChar(Chr: AnsiChar; const Str: RawUTF8): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
/// split a RawUTF8 string into two strings, according to SepStr separator
// - if SepStr is not found, LeftStr=Str and RightStr=''
// - if ToUpperCase is TRUE, then LeftStr and RightStr will be made uppercase
procedure Split(const Str, SepStr: RawUTF8; var LeftStr, RightStr: RawUTF8; ToUpperCase: boolean=false); overload;
/// split a RawUTF8 string into two strings, according to SepStr separator
// - this overloaded function returns the right string as function result
// - if SepStr is not found, LeftStr=Str and result=''
// - if ToUpperCase is TRUE, then LeftStr and result will be made uppercase
function Split(const Str, SepStr: RawUTF8; var LeftStr: RawUTF8; ToUpperCase: boolean=false): RawUTF8; overload;
/// returns the left part of a RawUTF8 string, according to SepStr separator
// - if SepStr is found, returns Str first chars until (and excluding) SepStr
// - if SepStr is not found, returns Str
function Split(const Str, SepStr: RawUTF8; StartPos: integer=1): RawUTF8; overload;
/// split a RawUTF8 string into several strings, according to SepStr separator
// - this overloaded function will fill a DestPtr[] array of PRawUTF8
// - if any DestPtr[]=nil, the item will be skipped
// - if input Str end before al SepStr[] are found, DestPtr[] is set to ''
// - returns the number of values extracted into DestPtr[]
function Split(const Str: RawUTF8; const SepStr: array of RawUTF8;
const DestPtr: array of PRawUTF8): PtrInt; overload;
/// returns the last occurence of the given SepChar separated context
// - e.g. SplitRight('01/2/34','/')='34'
// - if SepChar doesn't appear, will return Str, e.g. SplitRight('123','/')='123'
// - if LeftStr is supplied, the RawUTF8 it points to will be filled with
// the left part just before SepChar ('' if SepChar doesn't appear)
function SplitRight(const Str: RawUTF8; SepChar: AnsiChar; LeftStr: PRawUTF8=nil): RawUTF8;
/// returns the last occurence of the given SepChar separated context
// - e.g. SplitRight('path/one\two/file.ext','/\')='file.ext', i.e.
// SepChars='/\' will be like ExtractFileName() over RawUTF8 string
// - if SepChar doesn't appear, will return Str, e.g. SplitRight('123','/')='123'
function SplitRights(const Str, SepChar: RawUTF8): RawUTF8;
/// actual replacement function called by StringReplaceAll() on first match
// - not to be called as such, but defined globally for proper inlining
function StringReplaceAllProcess(const S, OldPattern, NewPattern: RawUTF8;
found: integer): RawUTF8;
/// fast version of StringReplace(S, OldPattern, NewPattern,[rfReplaceAll]);
function StringReplaceAll(const S, OldPattern, NewPattern: RawUTF8): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fast version of several cascaded StringReplaceAll()
function StringReplaceAll(const S: RawUTF8; const OldNewPatternPairs: array of RawUTF8): RawUTF8; overload;
/// fast replace of a specified char by a given string
function StringReplaceChars(const Source: RawUTF8; OldChar, NewChar: AnsiChar): RawUTF8;
/// fast replace of all #9 chars by a given string
function StringReplaceTabs(const Source,TabText: RawUTF8): RawUTF8;
/// format a text content with SQL-like quotes
// - UTF-8 version of the function available in SysUtils
// - this function implements what is specified in the official SQLite3
// documentation: "A string constant is formed by enclosing the string in single
// quotes ('). A single quote within the string can be encoded by putting two
// single quotes in a row - as in Pascal."
function QuotedStr(const S: RawUTF8; Quote: AnsiChar=''''): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// format a text content with SQL-like quotes
// - UTF-8 version of the function available in SysUtils
// - this function implements what is specified in the official SQLite3
// documentation: "A string constant is formed by enclosing the string in single
// quotes ('). A single quote within the string can be encoded by putting two
// single quotes in a row - as in Pascal."
procedure QuotedStr(const S: RawUTF8; Quote: AnsiChar; var result: RawUTF8); overload;
/// convert UTF-8 content into a JSON string
// - with proper escaping of the content, and surounding " characters
procedure QuotedStrJSON(const aText: RawUTF8; var result: RawUTF8;
const aPrefix: RawUTF8=''; const aSuffix: RawUTF8=''); overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert UTF-8 buffer into a JSON string
// - with proper escaping of the content, and surounding " characters
procedure QuotedStrJSON(P: PUTF8Char; PLen: PtrInt; var result: RawUTF8;
const aPrefix: RawUTF8=''; const aSuffix: RawUTF8=''); overload;
/// convert UTF-8 content into a JSON string
// - with proper escaping of the content, and surounding " characters
function QuotedStrJSON(const aText: RawUTF8): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// unquote a SQL-compatible string
// - the first character in P^ must be either ' or " then internal double quotes
// are transformed into single quotes
// - 'text '' end' -> text ' end
// - "text "" end" -> text " end
// - returns nil if P doesn't contain a valid SQL string
// - returns a pointer just after the quoted text otherwise
function UnQuoteSQLStringVar(P: PUTF8Char; out Value: RawUTF8): PUTF8Char;
/// unquote a SQL-compatible string
function UnQuoteSQLString(const Value: RawUTF8): RawUTF8;
/// unquote a SQL-compatible symbol name
// - e.g. '[symbol]' -> 'symbol' or '"symbol"' -> 'symbol'
function UnQuotedSQLSymbolName(const ExternalDBSymbol: RawUTF8): RawUTF8;
/// get the next character after a quoted buffer
// - the first character in P^ must be either ', either "
// - it will return the latest quote position, ignoring double quotes within
function GotoEndOfQuotedString(P: PUTF8Char): PUTF8Char;
{$ifdef HASINLINE}inline;{$endif}
/// get the next character after a quoted buffer
// - the first character in P^ must be "
// - it will return the latest " position, ignoring \" within
function GotoEndOfJSONString(P: PUTF8Char): PUTF8Char;
{$ifdef HASINLINE}inline;{$endif}
/// get the next character not in [#1..' ']
function GotoNextNotSpace(P: PUTF8Char): PUTF8Char;
{$ifdef HASINLINE}inline;{$endif}
/// get the next character not in [#9,' ']
function GotoNextNotSpaceSameLine(P: PUTF8Char): PUTF8Char;
{$ifdef HASINLINE}inline;{$endif}
/// get the next character in [#1..' ']
function GotoNextSpace(P: PUTF8Char): PUTF8Char;
{$ifdef HASINLINE}inline;{$endif}
/// check if the next character not in [#1..' '] matchs a given value
// - first ignore any non space character
// - then returns TRUE if P^=ch, setting P to the character after ch
// - or returns FALSE if P^<>ch, leaving P at the level of the unexpected char
function NextNotSpaceCharIs(var P: PUTF8Char; ch: AnsiChar): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// go to the beginning of the SQL statement, ignoring all blanks and comments
// - used to check the SQL statement command (e.g. is it a SELECT?)
function SQLBegin(P: PUTF8Char): PUTF8Char;
/// add a condition to a SQL WHERE clause, with an ' and ' if where is not void
procedure SQLAddWhereAnd(var where: RawUTF8; const condition: RawUTF8);
/// return true if the parameter is void or begin with a 'SELECT' SQL statement
// - used to avoid code injection and to check if the cache must be flushed
// - VACUUM, PRAGMA, or EXPLAIN statements also return true, since they won't
// change the data content
// - WITH recursive statement expect no INSERT/UPDATE/DELETE pattern in the SQL
// - if P^ is a SELECT and SelectClause is set to a variable, it would
// contain the field names, from SELECT ...field names... FROM
function isSelect(P: PUTF8Char; SelectClause: PRawUTF8=nil): boolean;
/// return true if IdemPChar(source,searchUp), and go to the next line of source
function IdemPCharAndGetNextLine(var source: PUTF8Char; searchUp: PAnsiChar): boolean;
/// return true if IdemPChar(source,searchUp), and retrieve the value item
// - typical use may be:
// ! if IdemPCharAndGetNextItem(P,
// ! 'CONTENT-DISPOSITION: FORM-DATA; NAME="',Name,'"') then ...
function IdemPCharAndGetNextItem(var source: PUTF8Char; const searchUp: RawUTF8;
var Item: RawUTF8; Sep: AnsiChar=#13): boolean;
/// fast go to next text line, ended by #13 or #13#10
// - returns the beginning of next line, or nil if source^=#0 was reached
function GotoNextLine(source: PUTF8Char): PUTF8Char;
{$ifdef HASINLINE}inline;{$endif}
/// compute the line length from a size-delimited source array of chars
// - will use fast assembly on x86-64 CPU, and expects TextEnd to be not nil
// - is likely to read some bytes after the TextEnd buffer, so GetLineSize()
// may be preferred, e.g. on memory mapped files
function BufferLineLength(Text, TextEnd: PUTF8Char): PtrInt;
{$ifndef CPUX64}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// compute the line length from source array of chars
// - if PEnd = nil, end counting at either #0, #13 or #10
// - otherwise, end counting at either #13 or #10
// - just a wrapper around BufferLineLength() checking PEnd=nil case
function GetLineSize(P,PEnd: PUTF8Char): PtrUInt;
{$ifdef HASINLINE}inline;{$endif}
/// returns true if the line length from source array of chars is not less than
// the specified count
function GetLineSizeSmallerThan(P,PEnd: PUTF8Char; aMinimalCount: integer): boolean;
/// return next CSV string from P
// - P=nil after call when end of text is reached
function GetNextItem(var P: PUTF8Char; Sep: AnsiChar= ','): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// return next CSV string from P
// - P=nil after call when end of text is reached
procedure GetNextItem(var P: PUTF8Char; Sep: AnsiChar; var result: RawUTF8); overload;
/// return next CSV string (unquoted if needed) from P
// - P=nil after call when end of text is reached
procedure GetNextItem(var P: PUTF8Char; Sep, Quote: AnsiChar; var result: RawUTF8); overload;
/// return trimmed next CSV string from P
// - P=nil after call when end of text is reached
procedure GetNextItemTrimed(var P: PUTF8Char; Sep: AnsiChar; var result: RawUTF8);
/// return next CRLF separated value string from P, ending #10 or #13#10 trimmed
// - any kind of line feed (CRLF or LF) will be handled, on all operating systems
// - as used e.g. by TSynNameValue.InitFromCSV and TDocVariantData.InitCSV
// - P=nil after call when end of text is reached
procedure GetNextItemTrimedCRLF(var P: PUTF8Char; var result: RawUTF8);
/// return next CSV string from P, nil if no more
// - this function returns the generic string type of the compiler, and
// therefore can be used with ready to be displayed text (e.g. for the VCL)
function GetNextItemString(var P: PChar; Sep: Char= ','): string;
/// return next string delimited with #13#10 from P, nil if no more
// - this function returns a RawUnicode string type
function GetNextStringLineToRawUnicode(var P: PChar): RawUnicode;
/// append some text lines with the supplied Values[]
// - if any Values[] item is '', no line is added
// - otherwise, appends 'Caption: Value', with Caption taken from CSV
procedure AppendCSVValues(const CSV: string; const Values: array of string;
var Result: string; const AppendBefore: string=#13#10);
/// return a CSV list of the iterated same value
// - e.g. CSVOfValue('?',3)='?,?,?'
function CSVOfValue(const Value: RawUTF8; Count: cardinal; const Sep: RawUTF8=','): RawUTF8;
/// retrieve the next CSV separated bit index
// - each bit was stored as BitIndex+1, i.e. 0 to mark end of CSV chunk
// - several bits set to one can be regrouped via 'first-last,' syntax
procedure SetBitCSV(var Bits; BitsCount: integer; var P: PUTF8Char);
/// convert a set of bit into a CSV content
// - each bit is stored as BitIndex+1, and separated by a ','
// - several bits set to one can be regrouped via 'first-last,' syntax
// - ',0' is always appended at the end of the CSV chunk to mark its end
function GetBitCSV(const Bits; BitsCount: integer): RawUTF8;
/// return next CSV string from P, nil if no more
// - output text would be trimmed from any left or right space
procedure GetNextItemShortString(var P: PUTF8Char; out Dest: ShortString; Sep: AnsiChar= ',');
/// decode next CSV hexadecimal string from P, nil if no more or not matching BinBytes
// - Bin is filled with 0 if the supplied CSV content is invalid
// - if Sep is #0, it will read the hexadecimal chars until a whitespace is reached
function GetNextItemHexDisplayToBin(var P: PUTF8Char; Bin: PByte; BinBytes: integer;
Sep: AnsiChar= ','): boolean;
type
/// some stack-allocated zero-terminated character buffer
// - as used by GetNextTChar64
TChar64 = array[0..63] of AnsiChar;
/// return next CSV string from P as a #0-ended buffer, false if no more
// - if Sep is #0, will copy all characters until next whitespace char
// - returns the number of bytes stored into Buf[]
function GetNextTChar64(var P: PUTF8Char; Sep: AnsiChar; out Buf: TChar64): PtrInt;
/// return next CSV string as unsigned integer from P, 0 if no more
// - if Sep is #0, it won't be searched for
function GetNextItemCardinal(var P: PUTF8Char; Sep: AnsiChar=','): PtrUInt;
/// return next CSV string as signed integer from P, 0 if no more
// - if Sep is #0, it won't be searched for
function GetNextItemInteger(var P: PUTF8Char; Sep: AnsiChar=','): PtrInt;
/// return next CSV string as 64-bit signed integer from P, 0 if no more
// - if Sep is #0, it won't be searched for
function GetNextItemInt64(var P: PUTF8Char; Sep: AnsiChar=','): Int64;
/// return next CSV string as 64-bit unsigned integer from P, 0 if no more
// - if Sep is #0, it won't be searched for
function GetNextItemQWord(var P: PUTF8Char; Sep: AnsiChar=','): QWord;
/// return next CSV hexadecimal string as 64-bit unsigned integer from P
// - returns 0 if no valid hexadecimal text is available in P
// - if Sep is #0, it won't be searched for
// - will first fill the 64-bit value with 0, then decode each two hexadecimal
// characters available in P
// - could be used to decode TTextWriter.AddBinToHexDisplayMinChars() output
function GetNextItemHexa(var P: PUTF8Char; Sep: AnsiChar=','): QWord;
/// return next CSV string as unsigned integer from P, 0 if no more
// - P^ will point to the first non digit character (the item separator, e.g.
// ',' for CSV)
function GetNextItemCardinalStrict(var P: PUTF8Char): PtrUInt;
/// return next CSV string as unsigned integer from P, 0 if no more
// - this version expects P^ to point to an Unicode char array
function GetNextItemCardinalW(var P: PWideChar; Sep: WideChar=','): PtrUInt;
/// return next CSV string as double from P, 0.0 if no more
// - if Sep is #0, will return all characters until next whitespace char
function GetNextItemDouble(var P: PUTF8Char; Sep: AnsiChar=','): double;
/// return next CSV string as currency from P, 0.0 if no more
// - if Sep is #0, will return all characters until next whitespace char
function GetNextItemCurrency(var P: PUTF8Char; Sep: AnsiChar=','): currency; overload;
{$ifdef HASINLINE}inline;{$endif}
/// return next CSV string as currency from P, 0.0 if no more
// - if Sep is #0, will return all characters until next whitespace char
procedure GetNextItemCurrency(var P: PUTF8Char; out result: currency; Sep: AnsiChar=','); overload;
/// return n-th indexed CSV string in P, starting at Index=0 for first one
function GetCSVItem(P: PUTF8Char; Index: PtrUInt; Sep: AnsiChar=','): RawUTF8; overload;
/// return n-th indexed CSV string (unquoted if needed) in P, starting at Index=0 for first one
function GetUnQuoteCSVItem(P: PUTF8Char; Index: PtrUInt; Sep: AnsiChar=','; Quote: AnsiChar=''''): RawUTF8; overload;
/// return n-th indexed CSV string in P, starting at Index=0 for first one
// - this function return the generic string type of the compiler, and
// therefore can be used with ready to be displayed text (i.e. the VCL)
function GetCSVItemString(P: PChar; Index: PtrUInt; Sep: Char=','): string;
/// return last CSV string in the supplied UTF-8 content
function GetLastCSVItem(const CSV: RawUTF8; Sep: AnsiChar=','): RawUTF8;
/// return the index of a Value in a CSV string
// - start at Index=0 for first one
// - return -1 if specified Value was not found in CSV items
function FindCSVIndex(CSV: PUTF8Char; const Value: RawUTF8; Sep: AnsiChar = ',';
CaseSensitive: boolean=true; TrimValue: boolean=false): integer;
/// add the strings in the specified CSV text into a dynamic array of UTF-8 strings
procedure CSVToRawUTF8DynArray(CSV: PUTF8Char; var Result: TRawUTF8DynArray;
Sep: AnsiChar=','; TrimItems: boolean=false; AddVoidItems: boolean=false); overload;
/// add the strings in the specified CSV text into a dynamic array of UTF-8 strings
procedure CSVToRawUTF8DynArray(const CSV,Sep,SepEnd: RawUTF8; var Result: TRawUTF8DynArray); overload;
/// return the corresponding CSV text from a dynamic array of UTF-8 strings
function RawUTF8ArrayToCSV(const Values: array of RawUTF8; const Sep: RawUTF8= ','): RawUTF8;
/// return the corresponding CSV quoted text from a dynamic array of UTF-8 strings
// - apply QuoteStr() function to each Values[] item
function RawUTF8ArrayToQuotedCSV(const Values: array of RawUTF8; const Sep: RawUTF8=',';
Quote: AnsiChar=''''): RawUTF8;
/// append some prefix to all CSV values
// ! AddPrefixToCSV('One,Two,Three','Pre')='PreOne,PreTwo,PreThree'
function AddPrefixToCSV(CSV: PUTF8Char; const Prefix: RawUTF8;
Sep: AnsiChar = ','): RawUTF8;
/// append a Value to a CSV string
procedure AddToCSV(const Value: RawUTF8; var CSV: RawUTF8; const Sep: RawUTF8 = ',');
{$ifdef HASINLINE}inline;{$endif}
/// change a Value within a CSV string
function RenameInCSV(const OldValue, NewValue: RawUTF8; var CSV: RawUTF8;
const Sep: RawUTF8 = ','): boolean;
/// quick helper to initialize a dynamic array of RawUTF8 from some constants
// - can be used e.g. as:
// ! MyArray := TRawUTF8DynArrayFrom(['a','b','c']);
function TRawUTF8DynArrayFrom(const Values: array of RawUTF8): TRawUTF8DynArray;
/// check if the TypeInfo() points to an "array of RawUTF8"
// - e.g. returns true for TypeInfo(TRawUTF8DynArray) or other sub-types
// defined as "type aNewType = type TRawUTF8DynArray"
function IsRawUTF8DynArray(typeinfo: pointer): boolean;
/// append one or several values to a local "array of const" variable
procedure AddArrayOfConst(var Dest: TTVarRecDynArray; const Values: array of const);
/// low-level efficient search of Value in Values[]
// - CaseSensitive=false will use StrICmp() for A..Z / a..z equivalence
function FindRawUTF8(Values: PRawUTF8; const Value: RawUTF8; ValuesCount: integer;
CaseSensitive: boolean): integer; overload;
/// return the index of Value in Values[], -1 if not found
// - CaseSensitive=false will use StrICmp() for A..Z / a..z equivalence
function FindRawUTF8(const Values: TRawUTF8DynArray; const Value: RawUTF8;
CaseSensitive: boolean=true): integer; overload;
{$ifdef HASINLINE}inline;{$endif}
/// return the index of Value in Values[], -1 if not found
// - CaseSensitive=false will use StrICmp() for A..Z / a..z equivalence
function FindRawUTF8(const Values: array of RawUTF8; const Value: RawUTF8;
CaseSensitive: boolean=true): integer; overload;
/// return the index of Value in Values[], -1 if not found
// - here name search would use fast IdemPropNameU() function
function FindPropName(const Names: array of RawUTF8; const Name: RawUTF8): integer; overload;
/// return the index of Value in Values[] using IdemPropNameU(), -1 if not found
// - typical use with a dynamic array is like:
// ! index := FindPropName(pointer(aDynArray),length(aDynArray),aValue);
function FindPropName(Values: PRawUTF8; const Value: RawUTF8;
ValuesCount: integer): integer; overload;
/// true if Value was added successfully in Values[]
function AddRawUTF8(var Values: TRawUTF8DynArray; const Value: RawUTF8;
NoDuplicates: boolean=false; CaseSensitive: boolean=true): boolean; overload;
/// add the Value to Values[], with an external count variable, for performance
procedure AddRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer;
const Value: RawUTF8); overload;
/// true if both TRawUTF8DynArray are the same
// - comparison is case-sensitive
function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray): boolean; overload;
/// true if both TRawUTF8DynArray are the same for a given number of items
// - A and B are expected to have at least Count items
// - comparison is case-sensitive
function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray; Count: integer): boolean; overload;
/// convert the string dynamic array into a dynamic array of UTF-8 strings
procedure StringDynArrayToRawUTF8DynArray(const Source: TStringDynArray;
var Result: TRawUTF8DynArray);
/// convert the string list into a dynamic array of UTF-8 strings
procedure StringListToRawUTF8DynArray(Source: TStringList; var Result: TRawUTF8DynArray);
/// search for a value from its uppercased named entry
// - i.e. iterate IdemPChar(source,UpperName) over every line of the source
// - returns the text just after UpperName if it has been found at line beginning
// - returns nil if UpperName was not found was not found at any line beginning
// - could be used as alternative to FindIniNameValue() and FindIniNameValueInteger()
// if there is no section, i.e. if search should not stop at '[' but at source end
function FindNameValue(P: PUTF8Char; UpperName: PAnsiChar): PUTF8Char; overload;
/// search and returns a value from its uppercased named entry
// - i.e. iterate IdemPChar(source,UpperName) over every line of the source
// - returns true and the trimmed text just after UpperName if it has been found
// at line beginning
// - returns false if UpperName was not found was not found at any line beginning
// - could be used e.g. to efficently extract a value from HTTP headers, whereas
// FindIniNameValue() is tuned for [section]-oriented INI files
function FindNameValue(const NameValuePairs: RawUTF8; UpperName: PAnsiChar;
var Value: RawUTF8): boolean; overload;
/// find a Name= Value in a [Section] of a INI RawUTF8 Content
// - this function scans the Content memory buffer, and is
// therefore very fast (no temporary TMemIniFile is created)
// - if Section equals '', find the Name= value before any [Section]
function FindIniEntry(const Content, Section,Name: RawUTF8): RawUTF8;
/// find a Name= Value in a [Section] of a INI WinAnsi Content
// - same as FindIniEntry(), but the value is converted from WinAnsi into UTF-8
function FindWinAnsiIniEntry(const Content, Section,Name: RawUTF8): RawUTF8;
/// find a Name= numeric Value in a [Section] of a INI RawUTF8 Content and
// return it as an integer, or 0 if not found
// - this function scans the Content memory buffer, and is
// therefore very fast (no temporary TMemIniFile is created)
// - if Section equals '', find the Name= value before any [Section]
function FindIniEntryInteger(const Content, Section,Name: RawUTF8): integer;
{$ifdef HASINLINE}inline;{$endif}
/// find a Name= Value in a [Section] of a .INI file
// - if Section equals '', find the Name= value before any [Section]
// - use internaly fast FindIniEntry() function above
function FindIniEntryFile(const FileName: TFileName; const Section,Name: RawUTF8): RawUTF8;
/// update a Name= Value in a [Section] of a INI RawUTF8 Content
// - this function scans and update the Content memory buffer, and is
// therefore very fast (no temporary TMemIniFile is created)
// - if Section equals '', update the Name= value before any [Section]
procedure UpdateIniEntry(var Content: RawUTF8; const Section,Name,Value: RawUTF8);
/// update a Name= Value in a [Section] of a .INI file
// - if Section equals '', update the Name= value before any [Section]
// - use internaly fast UpdateIniEntry() function above
procedure UpdateIniEntryFile(const FileName: TFileName; const Section,Name,Value: RawUTF8);
/// find the position of the [SEARCH] section in source
// - return true if [SEARCH] was found, and store pointer to the line after it in source
function FindSectionFirstLine(var source: PUTF8Char; search: PAnsiChar): boolean;
/// find the position of the [SEARCH] section in source
// - return true if [SEARCH] was found, and store pointer to the line after it in source
// - this version expects source^ to point to an Unicode char array
function FindSectionFirstLineW(var source: PWideChar; search: PUTF8Char): boolean;
/// retrieve the whole content of a section as a string
// - SectionFirstLine may have been obtained by FindSectionFirstLine() function above
function GetSectionContent(SectionFirstLine: PUTF8Char): RawUTF8; overload;
/// retrieve the whole content of a section as a string
// - use SectionFirstLine() then previous GetSectionContent()
function GetSectionContent(const Content, SectionName: RawUTF8): RawUTF8; overload;
/// delete a whole [Section]
// - if EraseSectionHeader is TRUE (default), then the [Section] line is also
// deleted together with its content lines
// - return TRUE if something was changed in Content
// - return FALSE if [Section] doesn't exist or is already void
function DeleteSection(var Content: RawUTF8; const SectionName: RawUTF8;
EraseSectionHeader: boolean=true): boolean; overload;
/// delete a whole [Section]
// - if EraseSectionHeader is TRUE (default), then the [Section] line is also
// deleted together with its content lines
// - return TRUE if something was changed in Content
// - return FALSE if [Section] doesn't exist or is already void
// - SectionFirstLine may have been obtained by FindSectionFirstLine() function above
function DeleteSection(SectionFirstLine: PUTF8Char; var Content: RawUTF8;
EraseSectionHeader: boolean=true): boolean; overload;
/// replace a whole [Section] content by a new content
// - create a new [Section] if none was existing
procedure ReplaceSection(var Content: RawUTF8; const SectionName,
NewSectionContent: RawUTF8); overload;
/// replace a whole [Section] content by a new content
// - create a new [Section] if none was existing
// - SectionFirstLine may have been obtained by FindSectionFirstLine() function above
procedure ReplaceSection(SectionFirstLine: PUTF8Char;
var Content: RawUTF8; const NewSectionContent: RawUTF8); overload;
/// return TRUE if Value of UpperName does exist in P, till end of current section
// - expect UpperName as 'NAME='
function ExistsIniName(P: PUTF8Char; UpperName: PAnsiChar): boolean;
/// find the Value of UpperName in P, till end of current section
// - expect UpperName as 'NAME='
function FindIniNameValue(P: PUTF8Char; UpperName: PAnsiChar): RawUTF8;
/// return TRUE if one of the Value of UpperName exists in P, till end of
// current section
// - expect UpperName e.g. as 'CONTENT-TYPE: '
// - expect UpperValues to be any upper value with left side matching, e.g. as
// used by IsHTMLContentTypeTextual() function:
// ! result := ExistsIniNameValue(htmlHeaders,HEADER_CONTENT_TYPE_UPPER,
// ! ['TEXT/','APPLICATION/JSON','APPLICATION/XML']);
// - warning: this function calls IdemPCharArray(), so expects UpperValues[]
/// items to have AT LEAST TWO CHARS (it will use fast initial 2 bytes compare)
function ExistsIniNameValue(P: PUTF8Char; const UpperName: RawUTF8;
const UpperValues: array of PAnsiChar): boolean;
/// find the integer Value of UpperName in P, till end of current section
// - expect UpperName as 'NAME='
// - return 0 if no NAME= entry was found
function FindIniNameValueInteger(P: PUTF8Char; UpperName: PAnsiChar): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
/// replace a value from a given set of name=value lines
// - expect UpperName as 'UPPERNAME=', otherwise returns false
// - if no UPPERNAME= entry was found, then Name+NewValue is added to Content
// - a typical use may be:
// ! UpdateIniNameValue(headers,HEADER_CONTENT_TYPE,HEADER_CONTENT_TYPE_UPPER,contenttype);
function UpdateIniNameValue(var Content: RawUTF8; const Name, UpperName, NewValue: RawUTF8): boolean;
/// read a File content into a String
// - content can be binary or text
// - returns '' if file was not found or any read error occured
// - wil use GetFileSize() API by default, unless HasNoSize is defined,
// and read will be done using a buffer (required e.g. for char files under Linux)
// - uses RawByteString for byte storage, whatever the codepage is
function StringFromFile(const FileName: TFileName; HasNoSize: boolean=false): RawByteString;
/// create a File from a string content
// - uses RawByteString for byte storage, whatever the codepage is
function FileFromString(const Content: RawByteString; const FileName: TFileName;
FlushOnDisk: boolean=false; FileDate: TDateTime=0): boolean;
/// get text File contents (even Unicode or UTF8) and convert it into a
// Charset-compatible AnsiString (for Delphi 7) or an UnicodeString (for Delphi
// 2009 and up) according to any BOM marker at the beginning of the file
// - before Delphi 2009, the current string code page is used (i.e. CurrentAnsiConvert)
function AnyTextFileToString(const FileName: TFileName; ForceUTF8: boolean=false): string;
/// get text file contents (even Unicode or UTF8) and convert it into an
// Unicode string according to any BOM marker at the beginning of the file
// - any file without any BOM marker will be interpreted as plain ASCII: in this
// case, the current string code page is used (i.e. CurrentAnsiConvert class)
function AnyTextFileToSynUnicode(const FileName: TFileName; ForceUTF8: boolean=false): SynUnicode;
/// get text file contents (even Unicode or UTF8) and convert it into an
// UTF-8 string according to any BOM marker at the beginning of the file
// - if AssumeUTF8IfNoBOM is FALSE, the current string code page is used (i.e.
// CurrentAnsiConvert class) for conversion from ANSI into UTF-8
// - if AssumeUTF8IfNoBOM is TRUE, any file without any BOM marker will be
// interpreted as UTF-8
function AnyTextFileToRawUTF8(const FileName: TFileName; AssumeUTF8IfNoBOM: boolean=false): RawUTF8;
/// read a TStream content into a String
// - it will read binary or text content from the current position until the
// end (using TStream.Size)
// - uses RawByteString for byte storage, whatever the codepage is
function StreamToRawByteString(aStream: TStream): RawByteString;
/// create a TStream from a string content
// - uses RawByteString for byte storage, whatever the codepage is
// - in fact, the returned TStream is a TRawByteString instance, since this
// function is just a wrapper around:
// ! result := TRawByteStringStream.Create(aString);
function RawByteStringToStream(const aString: RawByteString): TStream;
{$ifdef HASINLINE}inline;{$endif}
/// read an UTF-8 text from a TStream
// - format is Length(Integer):Text, i.e. the one used by WriteStringToStream
// - will return '' if there is no such text in the stream
// - you can set a MaxAllowedSize value, if you know how long the size should be
// - it will read from the current position in S: so if you just write into S,
// it could be a good idea to rewind it before call, e.g.:
// ! WriteStringToStream(Stream,aUTF8Text);
// ! Stream.Seek(0,soBeginning);
// ! str := ReadStringFromStream(Stream);
function ReadStringFromStream(S: TStream; MaxAllowedSize: integer=255): RawUTF8;
/// write an UTF-8 text into a TStream
// - format is Length(Integer):Text, i.e. the one used by ReadStringFromStream
function WriteStringToStream(S: TStream; const Text: RawUTF8): boolean;
/// get a file date and time, from its name
// - returns 0 if file doesn't exist
// - under Windows, will use GetFileAttributesEx fast API
function FileAgeToDateTime(const FileName: TFileName): TDateTime;
/// get a file size, from its name
// - returns 0 if file doesn't exist
// - under Windows, will use GetFileAttributesEx fast API
function FileSize(const FileName: TFileName): Int64; overload;
/// get a file size, from its handle
// - returns 0 if file doesn't exist
function FileSize(F: THandle): Int64; overload;
/// get low-level file information, in a cross-platform way
// - returns true on success
// - here file write/creation time are given as TUnixMSTime values, for better
// cross-platform process - note that FileCreateDateTime may not be supported
// by most Linux file systems, so the oldest timestamp available is returned
// as failover on such systems (probably the latest file metadata writing)
function FileInfoByHandle(aFileHandle: THandle; out FileId, FileSize,
LastWriteAccess, FileCreateDateTime: Int64): Boolean;
/// get a file date and time, from a FindFirst/FindNext search
// - the returned timestamp is in local time, not UTC
// - this method would use the F.Timestamp field available since Delphi XE2
function SearchRecToDateTime(const F: TSearchRec): TDateTime;
{$ifdef HASINLINE}inline;{$endif}
/// check if a FindFirst/FindNext found instance is actually a file
function SearchRecValidFile(const F: TSearchRec): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// check if a FindFirst/FindNext found instance is actually a folder
function SearchRecValidFolder(const F: TSearchRec): boolean;
{$ifdef HASINLINE}inline;{$endif}
const
/// operating-system dependent wildchar to match all files in a folder
FILES_ALL = {$ifdef MSWINDOWS}'*.*'{$else}'*'{$endif};
/// delete the content of a specified directory
// - only one level of file is deleted within the folder: no recursive deletion
// is processed by this function (for safety)
// - if DeleteOnlyFilesNotDirectory is TRUE, it won't remove the folder itself,
// but just the files found in it
function DirectoryDelete(const Directory: TFileName; const Mask: TFileName=FILES_ALL;
DeleteOnlyFilesNotDirectory: Boolean=false; DeletedCount: PInteger=nil): Boolean;
/// delete the files older than a given age in a specified directory
// - for instance, to delete all files older than one day:
// ! DirectoryDeleteOlderFiles(FolderName, 1);
// - only one level of file is deleted within the folder: no recursive deletion
// is processed by this function, unless Recursive is TRUE
// - if Recursive=true, caller should set TotalSize^=0 to have an accurate value
function DirectoryDeleteOlderFiles(const Directory: TFileName; TimePeriod: TDateTime;
const Mask: TFileName=FILES_ALL; Recursive: Boolean=false; TotalSize: PInt64=nil): Boolean;
/// creates a directory if not already existing
// - returns the full expanded directory name, including trailing backslash
// - returns '' on error, unless RaiseExceptionOnCreationFailure=true
function EnsureDirectoryExists(const Directory: TFileName;
RaiseExceptionOnCreationFailure: boolean=false): TFileName;
/// check if the directory is writable for the current user
// - try to write a small file with a random name
function IsDirectoryWritable(const Directory: TFileName): boolean;
/// compute an unique temporary file name
// - following 'exename_01234567.tmp' pattern, in the system temporary folder
function TemporaryFileName: TFileName;
type
{$A-}
/// file found result item, as returned by FindFiles()
// - Delphi "object" is buggy on stack -> also defined as record with methods
{$ifdef USERECORDWITHMETHODS}TFindFiles = record
{$else}TFindFiles = object{$endif}
public
/// the matching file name, including its folder name
Name: TFileName;
/// the matching file attributes
Attr: Integer;
/// the matching file size
Size: Int64;
/// the matching file date/time
Timestamp: TDateTime;
/// fill the item properties from a FindFirst/FindNext's TSearchRec
procedure FromSearchRec(const Directory: TFileName; const F: TSearchRec);
/// returns some ready-to-be-loggued text
function ToText: shortstring;
end;
{$A+}
/// result list, as returned by FindFiles()
TFindFilesDynArray = array of TFindFiles;
/// a pointer to a TFileName variable
PFileName = ^TFileName;
/// search for matching file names
// - just a wrapper around FindFirst/FindNext
// - you may specify several masks in Mask, e.g. as '*.jpg;*.jpeg'
function FindFiles(const Directory,Mask: TFileName;
const IgnoreFileName: TFileName=''; SortByName: boolean=false;
IncludesDir: boolean=true; SubFolder: Boolean=false): TFindFilesDynArray;
/// convert a result list, as returned by FindFiles(), into an array of Files[].Name
function FindFilesDynArrayToFileNames(const Files: TFindFilesDynArray): TFileNameDynArray;
/// ensure all files in Dest folder(s) do match the one in Reference
// - won't copy all files from Reference folders, but only update files already
// existing in Dest, which did change since last synchronization
// - will also process recursively nested folders if SubFolder is true
// - will use file content instead of file date check if ByContent is true
// - can optionally write the synched file name to the console
// - returns the number of files copied during the process
function SynchFolders(const Reference, Dest: TFileName; SubFolder: boolean=false;
ByContent: boolean=false; WriteFileNameToConsole: boolean=false): integer;
{$ifdef DELPHI5OROLDER}
/// DirectoryExists returns a boolean value that indicates whether the
// specified directory exists (and is actually a directory)
function DirectoryExists(const Directory: string): Boolean;
/// case-insensitive comparison of filenames
function SameFileName(const S1, S2: TFileName): Boolean;
/// retrieve the corresponding environment variable value
function GetEnvironmentVariable(const Name: string): string;
/// retrieve the full path name of the given execution module (e.g. library)
function GetModuleName(Module: HMODULE): TFileName;
/// try to encode a time
function TryEncodeTime(Hour, Min, Sec, MSec: Word; var Time: TDateTime): Boolean;
/// alias to ExcludeTrailingBackslash() function
function ExcludeTrailingPathDelimiter(const FileName: TFileName): TFileName;
/// alias to IncludeTrailingBackslash() function
function IncludeTrailingPathDelimiter(const FileName: TFileName): TFileName;
type
EOSError = class(Exception)
public
ErrorCode: DWORD;
end;
/// raise an EOSError exception corresponding to the last error reported by Windows
procedure RaiseLastOSError;
{$endif DELPHI5OROLDER}
{$ifdef DELPHI6OROLDER}
procedure VarCastError;
{$endif}
/// compute the file name, including its path if supplied, but without its extension
// - e.g. GetFileNameWithoutExt('/var/toto.ext') = '/var/toto'
// - may optionally return the extracted extension, as '.ext'
function GetFileNameWithoutExt(const FileName: TFileName;
Extension: PFileName=nil): TFileName;
/// extract a file extension from a file name, then compare with a comma
// separated list of extensions
// - e.g. GetFileNameExtIndex('test.log','exe,log,map')=1
// - will return -1 if no file extension match
// - will return any matching extension, starting count at 0
// - extension match is case-insensitive
function GetFileNameExtIndex(const FileName, CSVExt: TFileName): integer;
/// copy one file to another, similar to the Windows API
function CopyFile(const Source, Target: TFileName; FailIfExists: boolean): boolean;
/// copy the date of one file to another
function FileSetDateFrom(const Dest: TFileName; SourceHandle: integer): boolean;
/// retrieve a property value in a text-encoded class
// - follows the Delphi serialized text object format, not standard .ini
// - if the property is a string, the simple quotes ' are trimed
function FindObjectEntry(const Content, Name: RawUTF8): RawUTF8;
/// retrieve a filename property value in a text-encoded class
// - follows the Delphi serialized text object format, not standard .ini
// - if the property is a string, the simple quotes ' are trimed
// - any file path and any extension are trimmed
function FindObjectEntryWithoutExt(const Content, Name: RawUTF8): RawUTF8;
/// return true if UpperValue (Ansi) is contained in A^ (Ansi)
// - find UpperValue starting at word beginning, not inside words
function FindAnsi(A, UpperValue: PAnsiChar): boolean;
/// return true if UpperValue (Ansi) is contained in U^ (UTF-8 encoded)
// - find UpperValue starting at word beginning, not inside words
// - UTF-8 decoding is done on the fly (no temporary decoding buffer is used)
function FindUTF8(U: PUTF8Char; UpperValue: PAnsiChar): boolean;
/// return true if Upper (Unicode encoded) is contained in U^ (UTF-8 encoded)
// - will use the slow but accurate Operating System API to perform the
// comparison at Unicode-level
function FindUnicode(PW: PWideChar; Upper: PWideChar; UpperLen: PtrInt): boolean;
/// trim first lowercase chars ('otDone' will return 'Done' e.g.)
// - return a PUTF8Char to avoid any memory allocation
function TrimLeftLowerCase(const V: RawUTF8): PUTF8Char;
/// trim first lowercase chars ('otDone' will return 'Done' e.g.)
// - return an RawUTF8 string: enumeration names are pure 7bit ANSI with Delphi 7
// to 2007, and UTF-8 encoded with Delphi 2009+
function TrimLeftLowerCaseShort(V: PShortString): RawUTF8;
/// trim first lowercase chars ('otDone' will return 'Done' e.g.)
// - return a shortstring: enumeration names are pure 7bit ANSI with Delphi 7
// to 2007, and UTF-8 encoded with Delphi 2009+
function TrimLeftLowerCaseToShort(V: PShortString): ShortString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// trim first lowercase chars ('otDone' will return 'Done' e.g.)
// - return a shortstring: enumeration names are pure 7bit ANSI with Delphi 7
// to 2007, and UTF-8 encoded with Delphi 2009+
procedure TrimLeftLowerCaseToShort(V: PShortString; out result: ShortString); overload;
/// convert a CamelCase string into a space separated one
// - 'OnLine' will return 'On line' e.g., and 'OnMyLINE' will return 'On my LINE'
// - will handle capital words at the beginning, middle or end of the text, e.g.
// 'KLMFlightNumber' will return 'KLM flight number' and 'GoodBBCProgram' will
// return 'Good BBC program'
// - will handle a number at the beginning, middle or end of the text, e.g.
// 'Email12' will return 'Email 12'
// - '_' char is transformed into ' - '
// - '__' chars are transformed into ': '
// - return an RawUTF8 string: enumeration names are pure 7bit ANSI with Delphi 7
// to 2007, and UTF-8 encoded with Delphi 2009+
function UnCamelCase(const S: RawUTF8): RawUTF8; overload;
/// convert a CamelCase string into a space separated one
// - 'OnLine' will return 'On line' e.g., and 'OnMyLINE' will return 'On my LINE'
// - will handle capital words at the beginning, middle or end of the text, e.g.
// 'KLMFlightNumber' will return 'KLM flight number' and 'GoodBBCProgram' will
// return 'Good BBC program'
// - will handle a number at the beginning, middle or end of the text, e.g.
// 'Email12' will return 'Email 12'
// - return the char count written into D^
// - D^ and P^ are expected to be UTF-8 encoded: enumeration and property names
// are pure 7bit ANSI with Delphi 7 to 2007, and UTF-8 encoded with Delphi 2009+
// - '_' char is transformed into ' - '
// - '__' chars are transformed into ': '
function UnCamelCase(D, P: PUTF8Char): integer; overload;
/// convert a string into an human-friendly CamelCase identifier
// - replacing spaces or punctuations by an uppercase character
// - as such, it is not the reverse function to UnCamelCase()
procedure CamelCase(P: PAnsiChar; len: PtrInt; var s: RawUTF8;
const isWord: TSynByteSet=[ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z')]); overload;
/// convert a string into an human-friendly CamelCase identifier
// - replacing spaces or punctuations by an uppercase character
// - as such, it is not the reverse function to UnCamelCase()
procedure CamelCase(const text: RawUTF8; var s: RawUTF8;
const isWord: TSynByteSet=[ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z')]); overload;
{$ifdef HASINLINE}inline;{$endif}
/// UnCamelCase and translate a char buffer
// - P is expected to be #0 ended
// - return "string" type, i.e. UnicodeString for Delphi 2009+
procedure GetCaptionFromPCharLen(P: PUTF8Char; out result: string);
/// will get a class name as UTF-8
// - will trim 'T', 'TSyn', 'TSQL' or 'TSQLRecord' left side of the class name
// - will encode the class name as UTF-8 (for Unicode Delphi versions)
// - is used e.g. to extract the SQL table name for a TSQLRecord class
function GetDisplayNameFromClass(C: TClass): RawUTF8;
/// UnCamelCase and translate the class name, triming any left 'T', 'TSyn',
// 'TSQL' or 'TSQLRecord'
// - return generic VCL string type, i.e. UnicodeString for Delphi 2009+
function GetCaptionFromClass(C: TClass): string;
/// just a wrapper around vmtClassName to avoid a string conversion
function ClassNameShort(C: TClass): PShortString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// just a wrapper around vmtClassName to avoid a string conversion
function ClassNameShort(Instance: TObject): PShortString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// just a wrapper around vmtParent to avoid a function call
// - slightly faster than TClass.ClassParent thanks to proper inlining
function GetClassParent(C: TClass): TClass;
{$ifdef HASINLINE}inline;{$endif}
/// just a wrapper around vmtClassName to avoid a string/RawUTF8 conversion
function ToText(C: TClass): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// just a wrapper around vmtClassName to avoid a string/RawUTF8 conversion
procedure ToText(C: TClass; var result: RawUTF8); overload;
{$ifdef HASINLINE}inline;{$endif}
type
/// information about one method, as returned by GetPublishedMethods
TPublishedMethodInfo = record
/// the method name
Name: RawUTF8;
/// a callback to the method, for the given class instance
Method: TMethod;
end;
/// information about all methods, as returned by GetPublishedMethods
TPublishedMethodInfoDynArray = array of TPublishedMethodInfo;
/// retrieve published methods information about any class instance
// - will optionaly accept a Class, in this case Instance is ignored
// - will work with FPC and Delphi RTTI
function GetPublishedMethods(Instance: TObject; out Methods: TPublishedMethodInfoDynArray;
aClass: TClass = nil): integer;
{$ifdef LINUX}
const
ANSI_CHARSET = 0;
DEFAULT_CHARSET = 1;
SYMBOL_CHARSET = 2;
SHIFTJIS_CHARSET = $80;
HANGEUL_CHARSET = 129;
GB2312_CHARSET = 134;
CHINESEBIG5_CHARSET = 136;
OEM_CHARSET = 255;
JOHAB_CHARSET = 130;
HEBREW_CHARSET = 177;
ARABIC_CHARSET = 178;
GREEK_CHARSET = 161;
TURKISH_CHARSET = 162;
VIETNAMESE_CHARSET = 163;
THAI_CHARSET = 222;
EASTEUROPE_CHARSET = 238;
RUSSIAN_CHARSET = 204;
BALTIC_CHARSET = 186;
{$else}
{$ifdef FPC}
const
VIETNAMESE_CHARSET = 163;
{$endif}
{$endif}
/// convert a char set to a code page
function CharSetToCodePage(CharSet: integer): cardinal;
/// convert a code page to a char set
function CodePageToCharSet(CodePage: Cardinal): Integer;
/// retrieve the MIME content type from a supplied binary buffer
// - inspect the first bytes, to guess from standard known headers
// - return the MIME type, ready to be appended to a 'Content-Type: ' HTTP header
// - returns DefaultContentType if the binary buffer has an unknown layout
function GetMimeContentTypeFromBuffer(Content: Pointer; Len: PtrInt;
const DefaultContentType: RawUTF8): RawUTF8;
/// retrieve the MIME content type from its file name or a supplied binary buffer
// - will first check for known file extensions, then inspect the binary content
// - return the MIME type, ready to be appended to a 'Content-Type: ' HTTP header
// - default is 'application/octet-stream' (BINARY_CONTENT_TYPE) or
// 'application/fileextension' if FileName was specified
// - see @http://en.wikipedia.org/wiki/Internet_media_type for most common values
function GetMimeContentType(Content: Pointer; Len: PtrInt;
const FileName: TFileName=''): RawUTF8;
/// retrieve the HTTP header for MIME content type from a supplied binary buffer
// - just append HEADER_CONTENT_TYPE and GetMimeContentType() result
// - can be used as such:
// ! Call.OutHead := GetMimeContentTypeHeader(Call.OutBody,aFileName);
function GetMimeContentTypeHeader(const Content: RawByteString;
const FileName: TFileName=''): RawUTF8;
/// retrieve if some content is compressed, from a supplied binary buffer
// - returns TRUE, if the header in binary buffer "may" be compressed (this method
// can trigger false positives), e.g. begin with most common already compressed
// zip/gz/gif/png/jpeg/avi/mp3/mp4 markers (aka "magic numbers")
function IsContentCompressed(Content: Pointer; Len: PtrInt): boolean;
/// returns TRUE if the supplied HTML Headers contains 'Content-Type: text/...',
// 'Content-Type: application/json' or 'Content-Type: application/xml'
function IsHTMLContentTypeTextual(Headers: PUTF8Char): Boolean;
/// fast guess of the size, in pixels, of a JPEG memory buffer
// - will only scan for basic JPEG structure, up to the StartOfFrame (SOF) chunk
// - returns TRUE if the buffer is likely to be a JPEG picture, and set the
// Height + Width variable with its dimensions - but there may be false positive
// recognition, and no waranty that the memory buffer holds a valid JPEG picture
// - returns FALSE if the buffer does not have any expected SOI/SOF markers
function GetJpegSize(jpeg: PAnsiChar; len: PtrInt; out Height, Width: integer): boolean; overload;
/// fast guess of the size, in pixels, of a JPEG file
// - will only scan for basic JPEG structure, up to the StartOfFrame (SOF) chunk
// - returns TRUE if the buffer is likely to be a JPEG picture, and set the
// Height + Width variable with its dimensions - but there may be false positive
// recognition, and no waranty that the file is a valid JPEG picture
// - returns FALSE if the file content does not have any expected SOI/SOF markers
function GetJpegSize(const jpeg: TFileName; out Height, Width: integer): boolean; overload;
type
/// used by MultiPartFormDataDecode() to return one item of its data
TMultiPart = record
Name: RawUTF8;
FileName: RawUTF8;
ContentType: RawUTF8;
Encoding: RawUTF8;
Content: RawByteString;
end;
/// used by MultiPartFormDataDecode() to return all its data items
TMultiPartDynArray = array of TMultiPart;
/// decode multipart/form-data POST request content
// - following RFC1867
function MultiPartFormDataDecode(const MimeType,Body: RawUTF8;
var MultiPart: TMultiPartDynArray): boolean;
/// encode multipart fields and files
// - only one of them can be used because MultiPartFormDataDecode must implement
// both decodings
// - MultiPart: parts to build the multipart content from, which may be created
// using MultiPartFormDataAddFile/MultiPartFormDataAddField
// - MultiPartContentType: variable returning
// $ Content-Type: multipart/form-data; boundary=xxx
// where xxx is the first generated boundary
// - MultiPartContent: generated multipart content
function MultiPartFormDataEncode(const MultiPart: TMultiPartDynArray;
var MultiPartContentType, MultiPartContent: RawUTF8): boolean;
/// encode a file in a multipart array
// - FileName: file to encode
// - Multipart: where the part is added
// - Name: name of the part, is empty the name 'File###' is generated
function MultiPartFormDataAddFile(const FileName: TFileName;
var MultiPart: TMultiPartDynArray; const Name: RawUTF8 = ''): boolean;
/// encode a field in a multipart array
// - FieldName: field name of the part
// - FieldValue: value of the field
// - Multipart: where the part is added
function MultiPartFormDataAddField(const FieldName, FieldValue: RawUTF8;
var MultiPart: TMultiPartDynArray): boolean;
/// retrieve the index where to insert a PUTF8Char in a sorted PUTF8Char array
// - R is the last index of available entries in P^ (i.e. Count-1)
// - string comparison is case-sensitive StrComp (so will work with any PAnsiChar)
// - returns -1 if the specified Value was found (i.e. adding will duplicate a value)
// - will use fast O(log(n)) binary search algorithm
function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// retrieve the index where to insert a PUTF8Char in a sorted PUTF8Char array
// - this overloaded function accept a custom comparison function for sorting
// - R is the last index of available entries in P^ (i.e. Count-1)
// - string comparison is case-sensitive (so will work with any PAnsiChar)
// - returns -1 if the specified Value was found (i.e. adding will duplicate a value)
// - will use fast O(log(n)) binary search algorithm
function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char;
Compare: TUTF8Compare): PtrInt; overload;
/// retrieve the index where is located a PUTF8Char in a sorted PUTF8Char array
// - R is the last index of available entries in P^ (i.e. Count-1)
// - string comparison is case-sensitive StrComp (so will work with any PAnsiChar)
// - returns -1 if the specified Value was not found
// - will use inlined binary search algorithm with optimized x86_64 branchless asm
// - slightly faster than plain FastFindPUTF8CharSorted(P,R,Value,@StrComp)
function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt; overload;
/// retrieve the index where is located a PUTF8Char in a sorted uppercase PUTF8Char array
// - P[] array is expected to be already uppercased
// - searched Value is converted to uppercase before search via UpperCopy255Buf(),
// so is expected to be short, i.e. length < 250
// - R is the last index of available entries in P^ (i.e. Count-1)
// - returns -1 if the specified Value was not found
// - will use fast O(log(n)) binary search algorithm
// - slightly faster than plain FastFindPUTF8CharSorted(P,R,Value,@StrIComp)
function FastFindUpperPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt;
Value: PUTF8Char; ValueLen: PtrInt): PtrInt;
/// retrieve the index where is located a PUTF8Char in a sorted PUTF8Char array
// - R is the last index of available entries in P^ (i.e. Count-1)
// - string comparison will use the specified Compare function
// - returns -1 if the specified Value was not found
// - will use fast O(log(n)) binary search algorithm
function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char;
Compare: TUTF8Compare): PtrInt; overload;
/// retrieve the index of a PUTF8Char in a PUTF8Char array via a sort indexed
// - will use fast O(log(n)) binary search algorithm
function FastFindIndexedPUTF8Char(P: PPUTF8CharArray; R: PtrInt;
var SortedIndexes: TCardinalDynArray; Value: PUTF8Char;
ItemComp: TUTF8Compare): PtrInt;
/// add a RawUTF8 value in an alphaticaly sorted dynamic array of RawUTF8
// - returns the index where the Value was added successfully in Values[]
// - returns -1 if the specified Value was alredy present in Values[]
// (we must avoid any duplicate for O(log(n)) binary search)
// - if CoValues is set, its content will be moved to allow inserting a new
// value at CoValues[result] position - a typical usage of CoValues is to store
// the corresponding ID to each RawUTF8 item
// - if FastLocatePUTF8CharSorted() has been already called, this index can
// be set to optional ForceIndex parameter
// - by default, exact (case-sensitive) match is used; you can specify a custom
// compare function if needed in Compare optional parameter
function AddSortedRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer;
const Value: RawUTF8; CoValues: PIntegerDynArray=nil; ForcedIndex: PtrInt=-1;
Compare: TUTF8Compare=nil): PtrInt;
/// delete a RawUTF8 item in a dynamic array of RawUTF8
// - if CoValues is set, the integer item at the same index is also deleted
function DeleteRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer;
Index: integer; CoValues: PIntegerDynArray=nil): boolean; overload;
/// delete a RawUTF8 item in a dynamic array of RawUTF8;
function DeleteRawUTF8(var Values: TRawUTF8DynArray; Index: integer): boolean; overload;
/// sort a dynamic array of RawUTF8 items
// - if CoValues is set, the integer items are also synchronized
// - by default, exact (case-sensitive) match is used; you can specify a custom
// compare function if needed in Compare optional parameter
procedure QuickSortRawUTF8(var Values: TRawUTF8DynArray; ValuesCount: integer;
CoValues: PIntegerDynArray=nil; Compare: TUTF8Compare=nil);
/// sort a dynamic array of PUTF8Char items, via an external array of indexes
// - you can use FastFindIndexedPUTF8Char() for fast O(log(n)) binary search
procedure QuickSortIndexedPUTF8Char(Values: PPUtf8CharArray; Count: Integer;
var SortedIndexes: TCardinalDynArray; CaseSensitive: boolean=false);
/// fast search of an unsigned integer position in an integer array
// - Count is the number of cardinal entries in P^
// - returns P where P^=Value
// - returns nil if Value was not found
function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal;
/// fast search of an unsigned integer position in an integer array
// - Count is the number of integer entries in P^
// - return index of P^[index]=Value
// - return -1 if Value was not found
function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt;
/// fast search of an integer position in a 64-bit integer array
// - Count is the number of Int64 entries in P^
// - returns P where P^=Value
// - returns nil if Value was not found
function Int64Scan(P: PInt64Array; Count: PtrInt; const Value: Int64): PInt64;
/// fast search of an integer position in a signed 64-bit integer array
// - Count is the number of Int64 entries in P^
// - returns index of P^[index]=Value
// - returns -1 if Value was not found
function Int64ScanIndex(P: PInt64Array; Count: PtrInt; const Value: Int64): PtrInt;
/// fast search of an integer position in an unsigned 64-bit integer array
// - Count is the number of QWord entries in P^
// - returns index of P^[index]=Value
// - returns -1 if Value was not found
function QWordScanIndex(P: PQWordArray; Count: PtrInt; const Value: QWord): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
/// fast search of an unsigned integer in an integer array
// - returns true if P^=Value within Count entries
// - returns false if Value was not found
function IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean;
/// fast search of an integer value in a 64-bit integer array
// - returns true if P^=Value within Count entries
// - returns false if Value was not found
function Int64ScanExists(P: PInt64Array; Count: PtrInt; const Value: Int64): boolean;
/// fast search of a pointer-sized unsigned integer position
// in an pointer-sized integer array
// - Count is the number of pointer-sized integer entries in P^
// - return index of P^[index]=Value
// - return -1 if Value was not found
function PtrUIntScanIndex(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
/// fast search of a pointer-sized unsigned integer in an pointer-sized integer array
// - Count is the number of pointer-sized integer entries in P^
// - returns true if P^=Value within Count entries
// - returns false if Value was not found
function PtrUIntScan(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): pointer;
{$ifdef HASINLINE}inline;{$endif}
/// fast search of a pointer-sized unsigned integer position
// in an pointer-sized integer array
// - Count is the number of pointer-sized integer entries in P^
// - returns true if P^=Value within Count entries
// - returns false if Value was not found
function PtrUIntScanExists(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// fast search of an unsigned Byte value position in a Byte array
// - Count is the number of Byte entries in P^
// - return index of P^[index]=Value
// - return -1 if Value was not found
function ByteScanIndex(P: PByteArray; Count: PtrInt; Value: Byte): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
/// fast search of an unsigned Word value position in a Word array
// - Count is the number of Word entries in P^
// - return index of P^[index]=Value
// - return -1 if Value was not found
function WordScanIndex(P: PWordArray; Count: PtrInt; Value: word): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
/// fast search of a binary value position in a fixed-size array
// - Count is the number of entries in P^[]
// - return index of P^[index]=Elem^, comparing ElemSize bytes
// - return -1 if Value was not found
function AnyScanIndex(P,Elem: pointer; Count,ElemSize: PtrInt): PtrInt;
/// fast search of a binary value position in a fixed-size array
// - Count is the number of entries in P^[]
function AnyScanExists(P,Elem: pointer; Count,ElemSize: PtrInt): boolean;
/// sort an Integer array, low values first
procedure QuickSortInteger(ID: PIntegerArray; L, R: PtrInt); overload;
/// sort an Integer array, low values first
procedure QuickSortInteger(ID,CoValues: PIntegerArray; L, R: PtrInt); overload;
/// sort an Integer array, low values first
procedure QuickSortInteger(var ID: TIntegerDynArray); overload;
/// sort a 16 bit unsigned Integer array, low values first
procedure QuickSortWord(ID: PWordArray; L, R: PtrInt);
/// sort a 64-bit signed Integer array, low values first
procedure QuickSortInt64(ID: PInt64Array; L, R: PtrInt); overload;
/// sort a 64-bit unsigned Integer array, low values first
// - QWord comparison are implemented correctly under FPC or Delphi 2009+ -
// older compilers will use fast and exact SortDynArrayQWord()
procedure QuickSortQWord(ID: PQWordArray; L, R: PtrInt); overload;
/// sort a 64-bit Integer array, low values first
procedure QuickSortInt64(ID,CoValues: PInt64Array; L, R: PtrInt); overload;
type
/// event handler called by NotifySortedIntegerChanges()
// - Sender is an opaque const value, maybe a TObject or any pointer
TOnNotifySortedIntegerChange = procedure(const Sender; Value: integer) of object;
/// compares two 32-bit signed sorted integer arrays, and call event handlers
// to notify the corresponding modifications in an O(n) time
// - items in both old[] and new[] arrays are required to be sorted
procedure NotifySortedIntegerChanges(old, new: PIntegerArray; oldn, newn: PtrInt;
const added, deleted: TOnNotifySortedIntegerChange; const sender);
/// copy an integer array, then sort it, low values first
procedure CopyAndSortInteger(Values: PIntegerArray; ValuesCount: integer;
var Dest: TIntegerDynArray);
/// copy an integer array, then sort it, low values first
procedure CopyAndSortInt64(Values: PInt64Array; ValuesCount: integer;
var Dest: TInt64DynArray);
/// fast O(log(n)) binary search of an integer value in a sorted integer array
// - R is the last index of available integer entries in P^ (i.e. Count-1)
// - return index of P^[result]=Value
// - return -1 if Value was not found
function FastFindIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt; overload;
/// fast O(log(n)) binary search of an integer value in a sorted integer array
// - return index of Values[result]=Value
// - return -1 if Value was not found
function FastFindIntegerSorted(const Values: TIntegerDynArray; Value: integer): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fast O(log(n)) binary search of a 16 bit unsigned integer value in a sorted array
function FastFindWordSorted(P: PWordArray; R: PtrInt; Value: Word): PtrInt;
/// fast O(log(n)) binary search of a 64-bit signed integer value in a sorted array
// - R is the last index of available integer entries in P^ (i.e. Count-1)
// - return index of P^[result]=Value
// - return -1 if Value was not found
function FastFindInt64Sorted(P: PInt64Array; R: PtrInt; const Value: Int64): PtrInt; overload;
/// fast O(log(n)) binary search of a 64-bit unsigned integer value in a sorted array
// - R is the last index of available integer entries in P^ (i.e. Count-1)
// - return index of P^[result]=Value
// - return -1 if Value was not found
// - QWord comparison are implemented correctly under FPC or Delphi 2009+ -
// older compilers will fast and exact SortDynArrayQWord()
function FastFindQWordSorted(P: PQWordArray; R: PtrInt; const Value: QWord): PtrInt; overload;
/// sort a PtrInt array, low values first
procedure QuickSortPtrInt(P: PPtrIntArray; L, R: PtrInt);
{$ifdef HASINLINE}inline;{$endif}
/// fast O(log(n)) binary search of a PtrInt value in a sorted array
function FastFindPtrIntSorted(P: PPtrIntArray; R: PtrInt; Value: PtrInt): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// sort a pointer array, low values first
procedure QuickSortPointer(P: PPointerArray; L, R: PtrInt);
{$ifdef HASINLINE}inline;{$endif}
/// fast O(log(n)) binary search of a Pointer value in a sorted array
function FastFindPointerSorted(P: PPointerArray; R: PtrInt; Value: Pointer): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// retrieve the index where to insert an integer value in a sorted integer array
// - R is the last index of available integer entries in P^ (i.e. Count-1)
// - returns -1 if the specified Value was found (i.e. adding will duplicate a value)
function FastLocateIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt;
/// retrieve the index where to insert a word value in a sorted word array
// - R is the last index of available integer entries in P^ (i.e. Count-1)
// - returns -1 if the specified Value was found (i.e. adding will duplicate a value)
function FastLocateWordSorted(P: PWordArray; R: integer; Value: word): PtrInt;
/// add an integer value in a sorted dynamic array of integers
// - returns the index where the Value was added successfully in Values[]
// - returns -1 if the specified Value was already present in Values[]
// (we must avoid any duplicate for O(log(n)) binary search)
// - if CoValues is set, its content will be moved to allow inserting a new
// value at CoValues[result] position
function AddSortedInteger(var Values: TIntegerDynArray; var ValuesCount: integer;
Value: integer; CoValues: PIntegerDynArray=nil): PtrInt; overload;
/// add an integer value in a sorted dynamic array of integers
// - overloaded function which do not expect an external Count variable
function AddSortedInteger(var Values: TIntegerDynArray;
Value: integer; CoValues: PIntegerDynArray=nil): PtrInt; overload;
/// insert an integer value at the specified index position of a dynamic array
// of integers
// - if Index is invalid, the Value is inserted at the end of the array
function InsertInteger(var Values: TIntegerDynArray; var ValuesCount: integer;
Value: Integer; Index: PtrInt; CoValues: PIntegerDynArray=nil): PtrInt;
/// add an integer value at the end of a dynamic array of integers
// - returns TRUE if Value was added successfully in Values[], in this case
// length(Values) will be increased
function AddInteger(var Values: TIntegerDynArray; Value: integer;
NoDuplicates: boolean=false): boolean; overload;
/// add an integer value at the end of a dynamic array of integers
// - this overloaded function will use a separate Count variable (faster)
// - it won't search for any existing duplicate
procedure AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer;
Value: integer); overload;
{$ifdef HASINLINE}inline;{$endif}
/// add an integer array at the end of a dynamic array of integer
function AddInteger(var Values: TIntegerDynArray; const Another: TIntegerDynArray): PtrInt; overload;
/// add an integer value at the end of a dynamic array of integers
// - this overloaded function will use a separate Count variable (faster),
// and would allow to search for duplicates
// - returns TRUE if Value was added successfully in Values[], in this case
// ValuesCount will be increased, but length(Values) would stay fixed most
// of the time (since it stores the Values[] array capacity)
function AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer;
Value: integer; NoDuplicates: boolean): boolean; overload;
/// add a 16-bit integer value at the end of a dynamic array of integers
function AddWord(var Values: TWordDynArray; var ValuesCount: integer; Value: Word): PtrInt;
/// add a 64-bit integer value at the end of a dynamic array of integers
function AddInt64(var Values: TInt64DynArray; var ValuesCount: integer; Value: Int64): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// add a 64-bit integer value at the end of a dynamic array
function AddInt64(var Values: TInt64DynArray; Value: Int64): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// add a 64-bit integer array at the end of a dynamic array
function AddInt64(var Values: TInt64DynArray; const Another: TInt64DynArray): PtrInt; overload;
/// if not already existing, add a 64-bit integer value to a dynamic array
function AddInt64Once(var Values: TInt64DynArray; Value: Int64): PtrInt;
/// if not already existing, add a 64-bit integer value to a sorted dynamic array
procedure AddInt64Sorted(var Values: TInt64DynArray; Value: Int64);
/// delete any 32-bit integer in Values[]
procedure DeleteInteger(var Values: TIntegerDynArray; Index: PtrInt); overload;
/// delete any 32-bit integer in Values[]
procedure DeleteInteger(var Values: TIntegerDynArray; var ValuesCount: Integer; Index: PtrInt); overload;
/// remove some 32-bit integer from Values[]
// - Excluded is declared as var, since it will be sorted in-place during process
// if it contains more than ExcludedSortSize items (i.e. if the sort is worth it)
procedure ExcludeInteger(var Values, Excluded: TIntegerDynArray;
ExcludedSortSize: Integer=32);
/// ensure some 32-bit integer from Values[] will only contain Included[]
// - Included is declared as var, since it will be sorted in-place during process
// if it contains more than IncludedSortSize items (i.e. if the sort is worth it)
procedure IncludeInteger(var Values, Included: TIntegerDynArray;
IncludedSortSize: Integer=32);
/// sort and remove any 32-bit duplicated integer from Values[]
procedure DeduplicateInteger(var Values: TIntegerDynArray); overload;
/// sort and remove any 32-bit duplicated integer from Values[]
// - returns the new Values[] length
function DeduplicateInteger(var Values: TIntegerDynArray; Count: integer): integer; overload;
/// low-level function called by DeduplicateInteger()
function DeduplicateIntegerSorted(val: PIntegerArray; last: PtrInt): PtrInt;
/// create a new 32-bit integer dynamic array with the values from another one
procedure CopyInteger(const Source: TIntegerDynArray; out Dest: TIntegerDynArray);
/// delete any 16-bit integer in Values[]
procedure DeleteWord(var Values: TWordDynArray; Index: PtrInt);
/// delete any 64-bit integer in Values[]
procedure DeleteInt64(var Values: TInt64DynArray; Index: PtrInt); overload;
/// delete any 64-bit integer in Values[]
procedure DeleteInt64(var Values: TInt64DynArray; var ValuesCount: Integer; Index: PtrInt); overload;
/// remove some 64-bit integer from Values[]
// - Excluded is declared as var, since it will be sorted in-place during process
// if it contains more than ExcludedSortSize items (i.e. if the sort is worth it)
procedure ExcludeInt64(var Values, Excluded: TInt64DynArray;
ExcludedSortSize: Integer=32);
/// ensure some 64-bit integer from Values[] will only contain Included[]
// - Included is declared as var, since it will be sorted in-place during process
// if it contains more than IncludedSortSize items (i.e. if the sort is worth it)
procedure IncludeInt64(var Values, Included: TInt64DynArray;
IncludedSortSize: Integer=32);
/// sort and remove any 64-bit duplicated integer from Values[]
procedure DeduplicateInt64(var Values: TInt64DynArray); overload;
/// sort and remove any 64-bit duplicated integer from Values[]
// - returns the new Values[] length
function DeduplicateInt64(var Values: TInt64DynArray; Count: integer): integer; overload;
/// low-level function called by DeduplicateInt64()
// - warning: caller should ensure that last>0
function DeduplicateInt64Sorted(val: PInt64Array; last: PtrInt): PtrInt;
/// create a new 64-bit integer dynamic array with the values from another one
procedure CopyInt64(const Source: TInt64DynArray; out Dest: TInt64DynArray);
/// find the maximum 32-bit integer in Values[]
function MaxInteger(const Values: TIntegerDynArray; ValuesCount: PtrInt;
MaxStart: integer=-1): Integer;
/// sum all 32-bit integers in Values[]
function SumInteger(const Values: TIntegerDynArray; ValuesCount: PtrInt): Integer;
/// fill already allocated Reversed[] so that Reversed[Values[i]]=i
procedure Reverse(const Values: TIntegerDynArray; ValuesCount: PtrInt;
Reversed: PIntegerArray);
/// fill some values with i,i+1,i+2...i+Count-1
procedure FillIncreasing(Values: PIntegerArray; StartValue: integer; Count: PtrUInt);
/// copy some Int64 values into an unsigned integer array
procedure Int64ToUInt32(Values64: PInt64Array; Values32: PCardinalArray; Count: PtrInt);
/// append the strings in the specified CSV text into a dynamic array of integer
procedure CSVToIntegerDynArray(CSV: PUTF8Char; var Result: TIntegerDynArray;
Sep: AnsiChar= ',');
/// append the strings in the specified CSV text into a dynamic array of integer
procedure CSVToInt64DynArray(CSV: PUTF8Char; var Result: TInt64DynArray;
Sep: AnsiChar= ','); overload;
/// convert the strings in the specified CSV text into a dynamic array of integer
function CSVToInt64DynArray(CSV: PUTF8Char; Sep: AnsiChar= ','): TInt64DynArray; overload;
/// return the corresponding CSV text from a dynamic array of 32-bit integer
// - you can set some custom Prefix and Suffix text
function IntegerDynArrayToCSV(Values: PIntegerArray; ValuesCount: integer;
const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; InlinedValue: boolean=false): RawUTF8; overload;
/// return the corresponding CSV text from a dynamic array of 32-bit integer
// - you can set some custom Prefix and Suffix text
function IntegerDynArrayToCSV(const Values: TIntegerDynArray;
const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; InlinedValue: boolean=false): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// return the corresponding CSV text from a dynamic array of 64-bit integers
// - you can set some custom Prefix and Suffix text
function Int64DynArrayToCSV(Values: PInt64Array; ValuesCount: integer;
const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; InlinedValue: boolean=false): RawUTF8; overload;
/// return the corresponding CSV text from a dynamic array of 64-bit integers
// - you can set some custom Prefix and Suffix text
function Int64DynArrayToCSV(const Values: TInt64DynArray;
const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; InlinedValue: boolean=false): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// quick helper to initialize a dynamic array of integer from some constants
// - can be used e.g. as:
// ! MyArray := TIntegerDynArrayFrom([1,2,3]);
// - see also FromI32()
function TIntegerDynArrayFrom(const Values: array of integer): TIntegerDynArray;
/// quick helper to initialize a dynamic array of integer from 64-bit integers
// - will raise a ESynException if any Value[] can not fit into 32-bit, unless
// raiseExceptionOnOverflow is FALSE and the returned array slot is filled
// with maxInt/minInt
function TIntegerDynArrayFrom64(const Values: TInt64DynArray;
raiseExceptionOnOverflow: boolean=true): TIntegerDynArray;
/// quick helper to initialize a dynamic array of 64-bit integers from 32-bit values
// - see also FromI64() for 64-bit signed integer values input
function TInt64DynArrayFrom(const Values: TIntegerDynArray): TInt64DynArray;
/// quick helper to initialize a dynamic array of 64-bit integers from 32-bit values
// - see also FromU64() for 64-bit unsigned integer values input
function TQWordDynArrayFrom(const Values: TCardinalDynArray): TQWordDynArray;
/// initializes a dynamic array from a set of 32-bit integer signed values
function FromI32(const Values: array of integer): TIntegerDynArray;
{$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// initializes a dynamic array from a set of 32-bit integer unsigned values
function FromU32(const Values: array of cardinal): TCardinalDynArray;
{$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// initializes a dynamic array from a set of 64-bit integer signed values
function FromI64(const Values: array of Int64): TInt64DynArray;
{$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// initializes a dynamic array from a set of 64-bit integer unsigned values
function FromU64(const Values: array of QWord): TQWordDynArray;
{$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif}
type
/// used to store and retrieve Words in a sorted array
// - Delphi "object" is buggy on stack -> also defined as record with methods
{$ifdef USERECORDWITHMETHODS}TSortedWordArray = record
{$else}TSortedWordArray = object{$endif}
public
/// the actual 16-bit word storage
Values: TWordDynArray;
/// how many items are currently in Values[]
Count: PtrInt;
/// add a value into the sorted array
// - return the index of the new inserted value into the Values[] array
// - return -(foundindex+1) if this value is already in the Values[] array
function Add(aValue: Word): PtrInt;
/// return the index if the supplied value in the Values[] array
// - return -1 if not found
function IndexOf(aValue: Word): PtrInt; {$ifdef HASINLINE}inline;{$endif}
end;
PSortedWordArray = ^TSortedWordArray;
/// used to store and retrieve Integers in a sorted array
// - Delphi "object" is buggy on stack -> also defined as record with methods
{$ifdef USERECORDWITHMETHODS}TSortedIntegerArray = record
{$else}TSortedIntegerArray = object{$endif}
public
/// the actual 32-bit integers storage
Values: TIntegerDynArray;
/// how many items are currently in Values[]
Count: PtrInt;
/// add a value into the sorted array
// - return the index of the new inserted value into the Values[] array
// - return -(foundindex+1) if this value is already in the Values[] array
function Add(aValue: integer): PtrInt;
/// return the index if the supplied value in the Values[] array
// - return -1 if not found
function IndexOf(aValue: integer): PtrInt; {$ifdef HASINLINE}inline;{$endif}
end;
PSortedIntegerArray = ^TSortedIntegerArray;
/// comparison function as expected by MedianQuickSelect()
// - should return TRUE if Values[IndexA]>Values[IndexB]
TOnValueGreater = function(IndexA,IndexB: PtrInt): boolean of object;
/// compute the median of an integer serie of values, using "Quickselect"
// - based on the algorithm described in "Numerical recipes in C", Second Edition,
// translated from Nicolas Devillard's C code: http://ndevilla.free.fr/median/median
// - warning: the supplied Integer array is modified in-place during the process,
// and won't be fully sorted on output (this is no QuickSort alternative)
function MedianQuickSelectInteger(Values: PIntegerArray; n: integer): integer;
/// compute the median of a serie of values, using "Quickselect"
// - based on the algorithm described in "Numerical recipes in C", Second Edition
// - expect the values information to be available from a comparison callback
// - this version will use a temporary index list to exchange items order
// (supplied as a TSynTempBuffer), so won't change the supplied values themself
// - returns the index of the median Value
function MedianQuickSelect(const OnCompare: TOnValueGreater; n: integer;
var TempBuffer: TSynTempBuffer): integer;
/// compute GCD of two integers using substraction-based Euclidean algorithm
function gcd(a, b: cardinal): cardinal;
/// performs a QuickSort using a comparison callback
procedure QuickSortCompare(const OnCompare: TOnValueGreater;
Index: PIntegerArray; L,R: PtrInt);
/// convert a cardinal into a 32-bit variable-length integer buffer
function ToVarUInt32(Value: cardinal; Dest: PByte): PByte;
/// return the number of bytes necessary to store a 32-bit variable-length integer
// - i.e. the ToVarUInt32() buffer size
function ToVarUInt32Length(Value: PtrUInt): PtrUInt;
{$ifdef HASINLINE}inline;{$endif}
/// return the number of bytes necessary to store some data with a its
// 32-bit variable-length integer legnth
function ToVarUInt32LengthWithData(Value: PtrUInt): PtrUInt;
{$ifdef HASINLINE}inline;{$endif}
/// convert an integer into a 32-bit variable-length integer buffer
// - store negative values as cardinal two-complement, i.e.
// 0=0,1=1,2=-1,3=2,4=-2...
function ToVarInt32(Value: PtrInt; Dest: PByte): PByte;
{$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// convert a 32-bit variable-length integer buffer into a cardinal
// - fast inlined process for any number < 128
// - use overloaded FromVarUInt32() or FromVarUInt32Safe() with a SourceMax
// pointer to avoid any potential buffer overflow
function FromVarUInt32(var Source: PByte): cardinal; overload;
{$ifdef HASINLINE}inline;{$endif}
/// safely convert a 32-bit variable-length integer buffer into a cardinal
// - slower but safer process checking out of boundaries memory access in Source
// - SourceMax is expected to be not nil, and to point to the first byte
// just after the Source memory buffer
// - returns nil on error, or point to next input data on successful decoding
function FromVarUInt32Safe(Source, SourceMax: PByte; out Value: cardinal): PByte;
/// convert a 32-bit variable-length integer buffer into a cardinal
// - will call FromVarUInt32() if SourceMax=nil, or FromVarUInt32Safe() if set
// - returns false on error, true if Value has been set properly
function FromVarUInt32(var Source: PByte; SourceMax: PByte; out Value: cardinal): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert a 32-bit variable-length integer buffer into a cardinal
// - this version could be called if number is likely to be > $7f, so it
// inlining the first byte won't make any benefit
function FromVarUInt32Big(var Source: PByte): cardinal;
/// convert a 32-bit variable-length integer buffer into a cardinal
// - used e.g. when inlining FromVarUInt32()
// - this version must be called if Source^ has already been checked to be > $7f
// ! result := Source^;
// ! inc(Source);
// ! if result>$7f then
// ! result := (result and $7F) or FromVarUInt32Up128(Source);
function FromVarUInt32Up128(var Source: PByte): cardinal;
/// convert a 32-bit variable-length integer buffer into a cardinal
// - this version must be called if Source^ has already been checked to be > $7f
function FromVarUInt32High(var Source: PByte): cardinal;
/// convert a 32-bit variable-length integer buffer into an integer
// - decode negative values from cardinal two-complement, i.e.
// 0=0,1=1,2=-1,3=2,4=-2...
function FromVarInt32(var Source: PByte): integer;
/// convert a UInt64 into a 64-bit variable-length integer buffer
function ToVarUInt64(Value: QWord; Dest: PByte): PByte;
/// convert a 64-bit variable-length integer buffer into a UInt64
function FromVarUInt64(var Source: PByte): QWord; overload;
/// safely convert a 64-bit variable-length integer buffer into a UInt64
// - slower but safer process checking out of boundaries memory access in Source
// - SourceMax is expected to be not nil, and to point to the first byte
// just after the Source memory buffer
// - returns nil on error, or point to next input data on successful decoding
function FromVarUInt64Safe(Source, SourceMax: PByte; out Value: QWord): PByte;
/// convert a 64-bit variable-length integer buffer into a UInt64
// - will call FromVarUInt64() if SourceMax=nil, or FromVarUInt64Safe() if set
// - returns false on error, true if Value has been set properly
function FromVarUInt64(var Source: PByte; SourceMax: PByte; out Value: Qword): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert a Int64 into a 64-bit variable-length integer buffer
function ToVarInt64(Value: Int64; Dest: PByte): PByte; {$ifdef HASINLINE}inline;{$endif}
/// convert a 64-bit variable-length integer buffer into a Int64
function FromVarInt64(var Source: PByte): Int64;
/// convert a 64-bit variable-length integer buffer into a Int64
// - this version won't update the Source pointer
function FromVarInt64Value(Source: PByte): Int64;
/// jump a value in the 32-bit or 64-bit variable-length integer buffer
function GotoNextVarInt(Source: PByte): pointer; {$ifdef HASINLINE}inline;{$endif}
/// convert a RawUTF8 into an UTF-8 encoded variable-length buffer
function ToVarString(const Value: RawUTF8; Dest: PByte): PByte;
/// jump a value in variable-length text buffer
function GotoNextVarString(Source: PByte): pointer; {$ifdef HASINLINE}inline;{$endif}
/// retrieve a variable-length UTF-8 encoded text buffer in a newly allocation RawUTF8
function FromVarString(var Source: PByte): RawUTF8; overload;
/// safe retrieve a variable-length UTF-8 encoded text buffer in a newly allocation RawUTF8
// - supplied SourceMax value will avoid any potential buffer overflow
function FromVarString(var Source: PByte; SourceMax: PByte): RawUTF8; overload;
/// retrieve a variable-length text buffer
// - this overloaded function will set the supplied code page to the AnsiString
procedure FromVarString(var Source: PByte; var Value: RawByteString;
CodePage: integer); overload;
/// retrieve a variable-length text buffer
// - this overloaded function will set the supplied code page to the AnsiString
// and will also check for the SourceMax end of buffer
// - returns TRUE on success, or FALSE on any buffer overload detection
function FromVarString(var Source: PByte; SourceMax: PByte;
var Value: RawByteString; CodePage: integer): boolean; overload;
/// retrieve a variable-length UTF-8 encoded text buffer in a temporary buffer
// - caller should call Value.Done after use of the Value.buf memory
// - this overloaded function would include a trailing #0, so Value.buf could
// be parsed as a valid PUTF8Char buffer (e.g. containing JSON)
procedure FromVarString(var Source: PByte; var Value: TSynTempBuffer); overload;
/// retrieve a variable-length UTF-8 encoded text buffer in a temporary buffer
// - caller should call Value.Done after use of the Value.buf memory
// - this overloaded function will also check for the SourceMax end of buffer,
// returning TRUE on success, or FALSE on any buffer overload detection
function FromVarString(var Source: PByte; SourceMax: PByte;
var Value: TSynTempBuffer): boolean; overload;
type
/// kind of result returned by FromVarBlob() function
TValueResult = record
/// start of data value
Ptr: PAnsiChar;
/// value length (in bytes)
Len: PtrInt;
end;
/// retrieve pointer and length to a variable-length text/blob buffer
function FromVarBlob(Data: PByte): TValueResult; {$ifdef HASINLINE}inline;{$endif}
{ ************ low-level RTTI types and conversion routines ***************** }
type
/// specify ordinal (tkInteger and tkEnumeration) storage size and sign
// - note: Int64 is stored as its own TTypeKind, not as tkInteger
TOrdType = (otSByte,otUByte,otSWord,otUWord,otSLong,otULong
{$ifdef FPC_NEWRTTI},otSQWord,otUQWord{$endif});
/// specify floating point (ftFloat) storage size and precision
// - here ftDouble is renamed ftDoub to avoid confusion with TSQLDBFieldType
TFloatType = (ftSingle,ftDoub,ftExtended,ftComp,ftCurr);
{$ifdef FPC}
/// available type families for FPC RTTI values
// - values differs from Delphi, and are taken from FPC typinfo.pp unit
// - here below, we defined tkLString instead of tkAString to match Delphi -
// see https://lists.freepascal.org/pipermail/fpc-devel/2013-June/032360.html
// "Compiler uses internally some LongStrings which is not possible to use
// for variable declarations" so tkLStringOld seems never used in practice
TTypeKind = (tkUnknown,tkInteger,tkChar,tkEnumeration,tkFloat,
tkSet,tkMethod,tkSString,tkLStringOld{=tkLString},tkLString{=tkAString},
tkWString,tkVariant,tkArray,tkRecord,tkInterface,
tkClass,tkObject,tkWChar,tkBool,tkInt64,tkQWord,
tkDynArray,tkInterfaceRaw,tkProcVar,tkUString,tkUChar,
tkHelper,tkFile,tkClassRef,tkPointer);
const
/// potentially managed types in TTypeKind RTTI enumerate
// - should match ManagedType*() functions
tkManagedTypes = [tkLStringOld,tkLString,tkWstring,tkUstring,tkArray,
tkObject,tkRecord,tkDynArray,tkInterface,tkVariant];
/// maps record or object in TTypeKind RTTI enumerate
tkRecordTypes = [tkObject,tkRecord];
/// maps record or object in TTypeKind RTTI enumerate
tkRecordKinds = [tkObject,tkRecord];
type
/// TTypeKind RTTI enumerate as defined in Delphi 6 and up
TDelphiTypeKind = (dkUnknown, dkInteger, dkChar, dkEnumeration, dkFloat,
dkString, dkSet, dkClass, dkMethod, dkWChar, dkLString, dkWString,
dkVariant, dkArray, dkRecord, dkInterface, dkInt64, dkDynArray,
dkUString, dkClassRef, dkPointer, dkProcedure);
const
/// convert FPC's TTypeKind to Delphi's RTTI enumerate
// - used internally for cross-compiler TDynArray binary serialization
FPCTODELPHI: array[TTypeKind] of TDelphiTypeKind = (
dkUnknown,dkInteger,dkChar,dkEnumeration,dkFloat,
dkSet,dkMethod,dkString,dkLString,dkLString,
dkWString,dkVariant,dkArray,dkRecord,dkInterface,
dkClass,dkRecord,dkWChar,dkEnumeration,dkInt64,dkInt64,
dkDynArray,dkInterface,dkProcedure,dkUString,dkWChar,
dkPointer,dkPointer,dkClassRef,dkPointer);
/// convert Delphi's TTypeKind to FPC's RTTI enumerate
DELPHITOFPC: array[TDelphiTypeKind] of TTypeKind = (
tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
tkSString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString,
tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray,
tkUString, tkClassRef, tkPointer, tkProcVar);
{$else}
/// available type families for Delphi 6 and up, similar to typinfo.pas
// - redefined here to be shared between SynCommons.pas and mORMot.pas,
// also leveraging FPC compatibility as much as possible (FPC's typinfo.pp
// is not convenient to share code with Delphi - see e.g. its tkLString)
TTypeKind = (tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
tkString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString,
tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray
{$ifdef UNICODE}, tkUString, tkClassRef, tkPointer, tkProcedure{$endif});
const
/// maps record or object in TTypeKind RTTI enumerate
tkRecordTypes = [tkRecord];
/// maps record or object in TTypeKind RTTI enumerate
tkRecordKinds = tkRecord;
{$endif FPC}
/// maps long string in TTypeKind RTTI enumerate
tkStringTypes =
[tkLString, {$ifdef FPC}tkLStringOld,{$endif} tkWString
{$ifdef HASVARUSTRING}, tkUString{$endif}];
/// maps 1, 8, 16, 32 and 64-bit ordinal in TTypeKind RTTI enumerate
tkOrdinalTypes =
[tkInteger, tkChar, tkWChar, tkEnumeration, tkSet, tkInt64
{$ifdef FPC},tkBool,tkQWord{$endif}];
/// quick retrieve how many bytes an ordinal consist in
ORDTYPE_SIZE: array[TOrdType] of byte =
(1,1,2,2,4,4{$ifdef FPC_NEWRTTI},8,8{$endif});
type
PTypeKind = ^TTypeKind;
TTypeKinds = set of TTypeKind;
POrdType = ^TOrdType;
PFloatType = ^TFloatType;
function ToText(k: TTypeKind): PShortString; overload;
type
/// function prototype to be used for TDynArray Sort and Find method
// - common functions exist for base types: see e.g. SortDynArrayBoolean,
// SortDynArrayByte, SortDynArrayWord, SortDynArrayInteger, SortDynArrayCardinal,
// SortDynArrayInt64, SortDynArrayQWord, SordDynArraySingle, SortDynArrayDouble,
// SortDynArrayAnsiString, SortDynArrayAnsiStringI, SortDynArrayUnicodeString,
// SortDynArrayUnicodeStringI, SortDynArrayString, SortDynArrayStringI
// - any custom type (even records) can be compared then sort by defining
// such a custom function
// - must return 0 if A=B, -1 if 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;
/// optional event called by TDynArray.LoadFrom method after each item load
// - could be used e.g. for string interning or some custom initialization process
// - won't be called if the dynamic array has ElemType=nil
TDynArrayAfterLoadFrom = procedure(var A) of object;
/// internal enumeration used to specify some standard Delphi arrays
// - will be used e.g. to match JSON serialization or TDynArray search
// (see TDynArray and TDynArrayHash InitSpecific method)
// - djBoolean would generate an array of JSON boolean values
// - djByte .. djTimeLog match numerical JSON values
// - djDateTime .. djHash512 match textual JSON values
// - djVariant will match standard variant JSON serialization (including
// TDocVariant or other custom types, if any)
// - djCustom will be used for registered JSON serializer (invalid for
// InitSpecific methods call)
// - see also djPointer and djObject constant aliases for a pointer or
// TObject field hashing / comparison
// - is used also by TDynArray.InitSpecific() to define the main field type
TDynArrayKind = (
djNone,
djBoolean, djByte, djWord, djInteger, djCardinal, djSingle,
djInt64, djQWord, djDouble, djCurrency, djTimeLog,
djDateTime, djDateTimeMS, djRawUTF8, djWinAnsi, djString,
djRawByteString, djWideString, djSynUnicode,
djHash128, djHash256, djHash512,
djInterface, {$ifndef NOVARIANTS}djVariant,{$endif}
djCustom);
/// internal set to specify some standard Delphi arrays
TDynArrayKinds = set of TDynArrayKind;
/// cross-compiler type used for string reference counter
// - FPC and Delphi don't always use the same type
TStrCnt = {$ifdef STRCNT32} longint {$else} SizeInt {$endif};
/// pointer to cross-compiler type used for string reference counter
PStrCnt = ^TStrCnt;
/// cross-compiler type used for dynarray reference counter
// - FPC uses PtrInt/SizeInt, Delphi uses longint even on CPU64
TDACnt = {$ifdef DACNT32} longint {$else} SizeInt {$endif};
/// pointer to cross-compiler type used for dynarray reference counter
PDACnt = ^TDACnt;
/// internal integer type used for string header length field
TStrLen = {$ifdef FPC}SizeInt{$else}longint{$endif};
/// internal pointer integer type used for string header length field
PStrLen = ^TStrLen;
/// internal pointer integer type used for dynamic array header length field
PDALen = PPtrInt;
{$ifdef FPC}
/// map the Delphi/FPC dynamic array header (stored before each instance)
// - define globally for proper inlining with FPC
// - match tdynarray type definition in dynarr.inc
TDynArrayRec = {packed} record
/// dynamic array reference count (basic memory management mechanism)
refCnt: TDACnt;
/// equals length-1
high: tdynarrayindex;
function GetLength: sizeint; inline;
procedure SetLength(len: sizeint); inline;
property length: sizeint read GetLength write SetLength;
end;
PDynArrayRec = ^TDynArrayRec;
{$endif FPC}
const
/// cross-compiler negative offset to TStrRec.length field
// - to be used inlined e.g. as PStrLen(p-_STRLEN)^
_STRLEN = SizeOf(TStrLen);
/// cross-compiler negative offset to TStrRec.refCnt field
// - to be used inlined e.g. as PStrCnt(p-_STRREFCNT)^
_STRREFCNT = Sizeof(TStrCnt)+_STRLEN;
/// cross-compiler negative offset to TDynArrayRec.high/length field
// - to be used inlined e.g. as PDALen(PtrUInt(Values)-_DALEN)^{$ifdef FPC}+1{$endif}
_DALEN = SizeOf(PtrInt);
/// cross-compiler negative offset to TDynArrayRec.refCnt field
// - to be used inlined e.g. as PDACnt(PtrUInt(Values)-_DAREFCNT)^
_DAREFCNT = Sizeof(TDACnt)+_DALEN;
function ToText(k: TDynArrayKind): PShortString; overload;
{$ifndef NOVARIANTS}
type
/// possible options for a TDocVariant JSON/BSON document storage
// - dvoIsArray and dvoIsObject will store the "Kind: TDocVariantKind" state -
// you should never have to define these two options directly
// - dvoNameCaseSensitive will be used for every name lookup - here
// case-insensitivity is restricted to a-z A-Z 0-9 and _ characters
// - dvoCheckForDuplicatedNames will be used for method
// TDocVariantData.AddValue(), but not when setting properties at
// variant level: for consistency, "aVariant.AB := aValue" will replace
// any previous value for the name "AB"
// - dvoReturnNullForUnknownProperty will be used when retrieving any value
// from its name (for dvObject kind of instance), or index (for dvArray or
// dvObject kind of instance)
// - by default, internal values will be copied by-value from one variant
// instance to another, to ensure proper safety - but it may be too slow:
// if you set dvoValueCopiedByReference, the internal
// TDocVariantData.VValue/VName instances will be copied by-reference,
// to avoid memory allocations, BUT it may break internal process if you change
// some values in place (since VValue/VName and VCount won't match) - as such,
// if you set this option, ensure that you use the content as read-only
// - any registered custom types may have an extended JSON syntax (e.g.
// TBSONVariant does for MongoDB types), and will be searched during JSON
// parsing, unless dvoJSONParseDoNotTryCustomVariants is set (slightly faster)
// - by default, it will only handle direct JSON [array] of {object}: but if
// you define dvoJSONObjectParseWithinString, it will also try to un-escape
// a JSON string first, i.e. handle "[array]" or "{object}" content (may be
// used e.g. when JSON has been retrieved from a database TEXT column) - is
// used for instance by VariantLoadJSON()
// - JSON serialization will follow the standard layout, unless
// dvoSerializeAsExtendedJson is set so that the property names would not
// be escaped with double quotes, writing '{name:"John",age:123}' instead of
// '{"name":"John","age":123}': this extended json layout is compatible with
// http://docs.mongodb.org/manual/reference/mongodb-extended-json and with
// TDocVariant JSON unserialization, also our SynCrossPlatformJSON unit, but
// NOT recognized by most JSON clients, like AJAX/JavaScript or C#/Java
// - by default, only integer/Int64/currency number values are allowed, unless
// dvoAllowDoubleValue is set and 32-bit floating-point conversion is tried,
// with potential loss of precision during the conversion
// - dvoInternNames and dvoInternValues will use shared TRawUTF8Interning
// instances to maintain a list of RawUTF8 names/values for all TDocVariant,
// so that redundant text content will be allocated only once on heap
TDocVariantOption =
(dvoIsArray, dvoIsObject,
dvoNameCaseSensitive, dvoCheckForDuplicatedNames,
dvoReturnNullForUnknownProperty,
dvoValueCopiedByReference, dvoJSONParseDoNotTryCustomVariants,
dvoJSONObjectParseWithinString, dvoSerializeAsExtendedJson,
dvoAllowDoubleValue, dvoInternNames, dvoInternValues);
/// set of options for a TDocVariant storage
// - you can use JSON_OPTIONS[true] if you want to create a fast by-reference
// local document as with _ObjFast/_ArrFast/_JsonFast - i.e.
// [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference]
// - when specifying the options, you should not include dvoIsArray nor
// dvoIsObject directly in the set, but explicitly define TDocVariantDataKind
TDocVariantOptions = set of TDocVariantOption;
/// pointer to a set of options for a TDocVariant storage
// - you may use e.g. @JSON_OPTIONS[true], @JSON_OPTIONS[false],
// @JSON_OPTIONS_FAST_STRICTJSON or @JSON_OPTIONS_FAST_EXTENDED
PDocVariantOptions = ^TDocVariantOptions;
const
/// some convenient TDocVariant options, as JSON_OPTIONS[CopiedByReference]
// - JSON_OPTIONS[false] is e.g. _Json() and _JsonFmt() functions default
// - JSON_OPTIONS[true] are used e.g. by _JsonFast() and _JsonFastFmt() functions
// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency
JSON_OPTIONS: array[Boolean] of TDocVariantOptions = (
[dvoReturnNullForUnknownProperty],
[dvoReturnNullForUnknownProperty,dvoValueCopiedByReference]);
/// same as JSON_OPTIONS[true], but can not be used as PDocVariantOptions
// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency
// - as used by _JsonFast()
JSON_OPTIONS_FAST =
[dvoReturnNullForUnknownProperty,dvoValueCopiedByReference];
/// same as JSON_OPTIONS_FAST, but including dvoAllowDoubleValue to parse any float
// - as used by _JsonFastFloat()
JSON_OPTIONS_FAST_FLOAT =
[dvoReturnNullForUnknownProperty,dvoValueCopiedByReference,dvoAllowDoubleValue];
/// TDocVariant options which may be used for plain JSON parsing
// - this won't recognize any extended syntax
JSON_OPTIONS_FAST_STRICTJSON: TDocVariantOptions =
[dvoReturnNullForUnknownProperty,dvoValueCopiedByReference,
dvoJSONParseDoNotTryCustomVariants];
/// TDocVariant options to be used for case-sensitive TSynNameValue-like
// storage, with optional extended JSON syntax serialization
// - consider using JSON_OPTIONS_FAST_EXTENDED for case-insensitive objects
JSON_OPTIONS_NAMEVALUE: array[boolean] of TDocVariantOptions = (
[dvoReturnNullForUnknownProperty,dvoValueCopiedByReference,
dvoNameCaseSensitive],
[dvoReturnNullForUnknownProperty,dvoValueCopiedByReference,
dvoNameCaseSensitive,dvoSerializeAsExtendedJson]);
/// TDocVariant options to be used for case-sensitive TSynNameValue-like
// storage, RawUTF8 interning and optional extended JSON syntax serialization
// - consider using JSON_OPTIONS_FAST_EXTENDED for case-insensitive objects,
// or JSON_OPTIONS_NAMEVALUE[] if you don't expect names and values interning
JSON_OPTIONS_NAMEVALUEINTERN: array[boolean] of TDocVariantOptions = (
[dvoReturnNullForUnknownProperty,dvoValueCopiedByReference,
dvoNameCaseSensitive,dvoInternNames,dvoInternValues],
[dvoReturnNullForUnknownProperty,dvoValueCopiedByReference,
dvoNameCaseSensitive,dvoInternNames,dvoInternValues,
dvoSerializeAsExtendedJson]);
/// TDocVariant options to be used so that JSON serialization would
// use the unquoted JSON syntax for field names
// - you could use it e.g. on a TSQLRecord variant published field to
// reduce the JSON escape process during storage in the database, by
// customizing your TSQLModel instance:
// ! (aModel.Props[TSQLMyRecord]['VariantProp'] as TSQLPropInfoRTTIVariant).
// ! DocVariantOptions := JSON_OPTIONS_FAST_EXTENDED;
// or - in a cleaner way - by overriding TSQLRecord.InternalDefineModel():
// ! class procedure TSQLMyRecord.InternalDefineModel(Props: TSQLRecordProperties);
// ! begin
// ! (Props.Fields.ByName('VariantProp') as TSQLPropInfoRTTIVariant).
// ! DocVariantOptions := JSON_OPTIONS_FAST_EXTENDED;
// ! end;
// or to set all variant fields at once:
// ! class procedure TSQLMyRecord.InternalDefineModel(Props: TSQLRecordProperties);
// ! begin
// ! Props.SetVariantFieldsDocVariantOptions(JSON_OPTIONS_FAST_EXTENDED);
// ! end;
// - consider using JSON_OPTIONS_NAMEVALUE[true] for case-sensitive
// TSynNameValue-like storage, or JSON_OPTIONS_FAST_EXTENDEDINTERN if you
// expect RawUTF8 names and values interning
JSON_OPTIONS_FAST_EXTENDED: TDocVariantOptions =
[dvoReturnNullForUnknownProperty,dvoValueCopiedByReference,
dvoSerializeAsExtendedJson];
/// TDocVariant options for JSON serialization with efficient storage
// - i.e. unquoted JSON syntax for field names and RawUTF8 interning
// - may be used e.g. for efficient persistence of similar data
// - consider using JSON_OPTIONS_FAST_EXTENDED if you don't expect
// RawUTF8 names and values interning, or need BSON variants parsing
JSON_OPTIONS_FAST_EXTENDEDINTERN: TDocVariantOptions =
[dvoReturnNullForUnknownProperty,dvoValueCopiedByReference,
dvoSerializeAsExtendedJson,dvoJSONParseDoNotTryCustomVariants,
dvoInternNames,dvoInternValues];
{$endif NOVARIANTS}
const
/// TDynArrayKind alias for a pointer field hashing / comparison
djPointer = {$ifdef CPU64}djInt64{$else}djCardinal{$endif};
/// TDynArrayKind alias for a TObject field hashing / comparison
djObject = djPointer;
type
/// the available JSON format, for TTextWriter.AddJSONReformat() and its
// JSONBufferReformat() and JSONReformat() wrappers
// - jsonCompact is the default machine-friendly single-line layout
// - jsonHumanReadable will add line feeds and indentation, for a more
// human-friendly result
// - jsonUnquotedPropName will emit the jsonHumanReadable layout, but
// with all property names being quoted only if necessary: this format
// could be used e.g. for configuration files - this format, similar to the
// one used in the MongoDB extended syntax, is not JSON compatible: do not
// use it e.g. with AJAX clients, but is would be handled as expected by all
// our units as valid JSON input, without previous correction
// - jsonUnquotedPropNameCompact will emit single-line layout with unquoted
// property names
TTextWriterJSONFormat = (
jsonCompact, jsonHumanReadable,
jsonUnquotedPropName, jsonUnquotedPropNameCompact);
TDynArrayObjArray = (oaUnknown, oaFalse, oaTrue);
/// a wrapper around a dynamic array with one dimension
// - provide TList-like methods using fast RTTI information
// - can be used to fast save/retrieve all memory content to a TStream
// - note that the "const Elem" is not checked at compile time nor runtime:
// you must ensure that Elem matchs the element type of the dynamic array
// - can use external Count storage to make Add() and Delete() much faster
// (avoid most reallocation of the memory buffer)
// - Note that TDynArray is just a wrapper around an existing dynamic array:
// methods can modify the content of the associated variable but the TDynArray
// doesn't contain any data by itself. It is therefore aimed to initialize
// a TDynArray wrapper on need, to access any existing dynamic array.
// - is defined as an object or as a record, due to a bug
// in Delphi 2009/2010 compiler (at least): this structure is not initialized
// if defined as an object on the stack, but will be as a record :(
{$ifdef UNDIRECTDYNARRAY}TDynArray = record
{$else}TDynArray = object {$endif}
private
fValue: PPointer;
fTypeInfo: pointer;
fElemType{$ifdef DYNARRAYELEMTYPE2}, fElemType2{$endif}: pointer;
fCountP: PInteger;
fCompare: TDynArraySortCompare;
fElemSize: cardinal;
fKnownSize: integer;
fParser: integer; // index to GlobalJSONCustomParsers.fParsers[]
fSorted: boolean;
fKnownType: TDynArrayKind;
fIsObjArray: TDynArrayObjArray;
function GetCount: PtrInt; {$ifdef HASINLINE}inline;{$endif}
procedure SetCount(aCount: PtrInt);
function GetCapacity: PtrInt; {$ifdef HASINLINE}inline;{$endif}
procedure SetCapacity(aCapacity: PtrInt);
procedure SetCompare(const aCompare: TDynArraySortCompare); {$ifdef HASINLINE}inline;{$endif}
function FindIndex(const Elem; aIndex: PIntegerDynArray;
aCompare: TDynArraySortCompare): PtrInt;
function GetArrayTypeName: RawUTF8;
function GetArrayTypeShort: PShortString;
function GetIsObjArray: boolean; {$ifdef HASINLINE}inline;{$endif}
function ComputeIsObjArray: boolean;
procedure SetIsObjArray(aValue: boolean); {$ifdef HASINLINE}inline;{$endif}
function LoadFromHeader(var Source: PByte; SourceMax: PByte): integer;
function LoadKnownType(Data,Source,SourceMax: PAnsiChar): boolean;
/// faster than RTL + handle T*ObjArray + ensure unique
procedure InternalSetLength(OldLength,NewLength: PtrUInt);
public
/// initialize the wrapper with a one-dimension dynamic array
// - the dynamic array must have been defined with its own type
// (e.g. TIntegerDynArray = array of Integer)
// - if aCountPointer is set, it will be used instead of length() to store
// the dynamic array items count - it will be much faster when adding
// elements to the array, because the dynamic array won't need to be
// resized each time - but in this case, you should use the Count property
// instead of length(array) or high(array) when accessing the data: in fact
// length(array) will store the memory size reserved, not the items count
// - if aCountPointer is set, its content will be set to 0, whatever the
// array length is, or the current aCountPointer^ value is
// - a sample usage may be:
// !var DA: TDynArray;
// ! A: TIntegerDynArray;
// !begin
// ! DA.Init(TypeInfo(TIntegerDynArray),A);
// ! (...)
// - a sample usage may be (using a count variable):
// !var DA: TDynArray;
// ! A: TIntegerDynArray;
// ! ACount: integer;
// ! i: integer;
// !begin
// ! DA.Init(TypeInfo(TIntegerDynArray),A,@ACount);
// ! for i := 1 to 100000 do
// ! DA.Add(i); // MUCH faster using the ACount variable
// ! (...) // now you should use DA.Count or Count instead of length(A)
procedure Init(aTypeInfo: pointer; var aValue; aCountPointer: PInteger=nil);
/// initialize the wrapper with a one-dimension dynamic array
// - this version accepts to specify how comparison should occur, using
// TDynArrayKind kind of first field
// - djNone and djCustom are too vague, and will raise an exception
// - no RTTI check is made over the corresponding array layout: you shall
// ensure that the aKind parameter matches the dynamic array element definition
// - aCaseInsensitive will be used for djRawUTF8..djHash512 text comparison
procedure InitSpecific(aTypeInfo: pointer; var aValue; aKind: TDynArrayKind;
aCountPointer: PInteger=nil; aCaseInsensitive: boolean=false);
/// define the reference to an external count integer variable
// - Init and InitSpecific methods will reset the aCountPointer to 0: you
// can use this method to set the external count variable without overriding
// the current value
procedure UseExternalCount(var aCountPointer: Integer);
{$ifdef HASINLINE}inline;{$endif}
/// low-level computation of KnownType and KnownSize fields from RTTI
// - do nothing if has already been set at initialization, or already computed
function GuessKnownType(exactType: boolean=false): TDynArrayKind;
/// check this dynamic array from the GlobalJSONCustomParsers list
// - returns TRUE if this array has a custom JSON parser
function HasCustomJSONParser: boolean;
/// initialize the wrapper to point to no dynamic array
procedure Void;
/// check if the wrapper points to a dynamic array
function IsVoid: boolean;
/// add an element to the dynamic array
// - warning: Elem must be of the same exact type than the dynamic array,
// and must be a reference to a variable (you can't write Add(i+10) e.g.)
// - returns the index of the added element in the dynamic array
// - note that because of dynamic array internal memory managment, adding
// may reallocate the list every time a record is added, unless an external
// count variable has been specified in Init(...,@Count) method
function Add(const Elem): PtrInt;
/// add an element to the dynamic array
// - this version add a void element to the array, and returns its index
// - note: if you use this method to add a new item with a reference to the
// dynamic array, using a local variable is needed under FPC:
// ! i := DynArray.New;
// ! with Values[i] do begin // otherwise Values is nil -> GPF
// ! Field1 := 1;
// ! ...
function New: integer;
/// add an element to the dynamic array at the position specified by Index
// - warning: Elem must be of the same exact type than the dynamic array,
// and must be a reference to a variable (you can't write Insert(10,i+10) e.g.)
procedure Insert(Index: PtrInt; const Elem);
/// get and remove the last element stored in the dynamic array
// - Add + Pop/Peek will implement a LIFO (Last-In-First-Out) stack
// - warning: Elem must be of the same exact type than the dynamic array
// - returns true if the item was successfully copied and removed
// - use Peek() if you don't want to remove the item
function Pop(var Dest): boolean;
/// get the last element stored in the dynamic array
// - Add + Pop/Peek will implement a LIFO (Last-In-First-Out) stack
// - warning: Elem must be of the same exact type than the dynamic array
// - returns true if the item was successfully copied into Dest
// - use Pop() if you also want to remove the item
function Peek(var Dest): boolean;
/// delete the whole dynamic array content
// - this method will recognize T*ObjArray types and free all instances
procedure Clear; {$ifdef HASINLINE}inline;{$endif}
/// delete the whole dynamic array content, ignoring exceptions
// - returns true if no exception occured when calling Clear, false otherwise
// - you should better not call this method, which will catch and ignore
// all exceptions - but it may somewhat make sense in a destructor
// - this method will recognize T*ObjArray types and free all instances
function ClearSafe: boolean;
/// delete one item inside the dynamic array
// - the deleted element is finalized if necessary
// - this method will recognize T*ObjArray types and free all instances
function Delete(aIndex: PtrInt): boolean;
/// search for an element value inside the dynamic array
// - return the index found (0..Count-1), or -1 if Elem was not found
// - will search for all properties content of the eLement: TList.IndexOf()
// searches by address, this method searches by content using the RTTI
// element description (and not the Compare property function)
// - use the Find() method if you want the search via the Compare property
// function, or e.g. to search only with some part of the element content
// - will work with simple types: binaries (byte, word, integer, Int64,
// Currency, array[0..255] of byte, packed records with no reference-counted
// type within...), string types (e.g. array of string), and packed records
// with binary and string types within (like TFileVersion)
// - won't work with not packed types (like a shorstring, or a record
// with byte or word fields with {$A+}): in this case, the padding data
// (i.e. the bytes between the aligned feeds can be filled as random, and
// there is no way with standard RTTI do know which they are)
// - warning: Elem must be of the same exact type than the dynamic array,
// and must be a reference to a variable (you can't write IndexOf(i+10) e.g.)
function IndexOf(const Elem): PtrInt;
/// search for an element value inside the dynamic array
// - this method will use the Compare property function for the search
// - return the index found (0..Count-1), or -1 if Elem was not found
// - if the array is sorted, it will use fast O(log(n)) binary search
// - if the array is not sorted, it will use slower O(n) iterating search
// - warning: Elem must be of the same exact type than the dynamic array,
// and must be a reference to a variable (you can't write Find(i+10) e.g.)
function Find(const Elem): PtrInt; overload;
/// search for an element value inside the dynamic array, from an external
// indexed lookup table
// - return the index found (0..Count-1), or -1 if Elem was not found
// - this method will use a custom comparison function, with an external
// integer table, as created by the CreateOrderedIndex() method: it allows
// multiple search orders in the same dynamic array content
// - if an indexed lookup is supplied, it must already be sorted:
// this function will then use fast O(log(n)) binary search
// - if an indexed lookup is not supplied (i.e aIndex=nil),
// this function will use slower but accurate O(n) iterating search
// - warning; the lookup index should be synchronized if array content
// is modified (in case of adding or deletion)
function Find(const Elem; const aIndex: TIntegerDynArray;
aCompare: TDynArraySortCompare): PtrInt; overload;
/// search for an element value, then fill all properties if match
// - this method will use the Compare property function for the search,
// or the supplied indexed lookup table and its associated compare function
// - if Elem content matches, all Elem fields will be filled with the record
// - can be used e.g. as a simple dictionary: if Compare will match e.g. the
// first string field (i.e. set to SortDynArrayString), you can fill the
// first string field with the searched value (if returned index is >= 0)
// - return the index found (0..Count-1), or -1 if Elem was not found
// - if the array is sorted, it will use fast O(log(n)) binary search
// - if the array is not sorted, it will use slower O(n) iterating search
// - warning: Elem must be of the same exact type than the dynamic array,
// and must be a reference to a variable (you can't write Find(i+10) e.g.)
function FindAndFill(var Elem; aIndex: PIntegerDynArray=nil;
aCompare: TDynArraySortCompare=nil): integer;
/// search for an element value, then delete it if match
// - this method will use the Compare property function for the search,
// or the supplied indexed lookup table and its associated compare function
// - if Elem content matches, this item will be deleted from the array
// - can be used e.g. as a simple dictionary: if Compare will match e.g. the
// first string field (i.e. set to SortDynArrayString), you can fill the
// first string field with the searched value (if returned index is >= 0)
// - return the index deleted (0..Count-1), or -1 if Elem was not found
// - if the array is sorted, it will use fast O(log(n)) binary search
// - if the array is not sorted, it will use slower O(n) iterating search
// - warning: Elem must be of the same exact type than the dynamic array,
// and must be a reference to a variable (you can't write Find(i+10) e.g.)
function FindAndDelete(const Elem; aIndex: PIntegerDynArray=nil;
aCompare: TDynArraySortCompare=nil): integer;
/// search for an element value, then update the item if match
// - this method will use the Compare property function for the search,
// or the supplied indexed lookup table and its associated compare function
// - if Elem content matches, this item will be updated with the supplied value
// - can be used e.g. as a simple dictionary: if Compare will match e.g. the
// first string field (i.e. set to SortDynArrayString), you can fill the
// first string field with the searched value (if returned index is >= 0)
// - return the index found (0..Count-1), or -1 if Elem was not found
// - if the array is sorted, it will use fast O(log(n)) binary search
// - if the array is not sorted, it will use slower O(n) iterating search
// - warning: Elem must be of the same exact type than the dynamic array,
// and must be a reference to a variable (you can't write Find(i+10) e.g.)
function FindAndUpdate(const Elem; aIndex: PIntegerDynArray=nil;
aCompare: TDynArraySortCompare=nil): integer;
/// search for an element value, then add it if none matched
// - this method will use the Compare property function for the search,
// or the supplied indexed lookup table and its associated compare function
// - if no Elem content matches, the item will added to the array
// - can be used e.g. as a simple dictionary: if Compare will match e.g. the
// first string field (i.e. set to SortDynArrayString), you can fill the
// first string field with the searched value (if returned index is >= 0)
// - return the index found (0..Count-1), or -1 if Elem was not found and
// the supplied element has been succesfully added
// - if the array is sorted, it will use fast O(log(n)) binary search
// - if the array is not sorted, it will use slower O(n) iterating search
// - warning: Elem must be of the same exact type than the dynamic array,
// and must be a reference to a variable (you can't write Find(i+10) e.g.)
function FindAndAddIfNotExisting(const Elem; aIndex: PIntegerDynArray=nil;
aCompare: TDynArraySortCompare=nil): integer;
/// sort the dynamic array elements, using the Compare property function
// - it will change the dynamic array content, and exchange all elements
// in order to be sorted in increasing order according to Compare function
procedure Sort(aCompare: TDynArraySortCompare=nil); overload;
/// sort some dynamic array elements, using the Compare property function
// - this method allows to sort only some part of the items
// - it will change the dynamic array content, and exchange all elements
// in order to be sorted in increasing order according to Compare function
procedure SortRange(aStart, aStop: integer; aCompare: TDynArraySortCompare=nil);
/// sort the dynamic array elements, using a Compare method (not function)
// - it will change the dynamic array content, and exchange all elements
// in order to be sorted in increasing order according to Compare function,
// unless aReverse is true
// - it won't mark the array as Sorted, since the comparer is local
procedure Sort(const aCompare: TEventDynArraySortCompare; aReverse: boolean=false); overload;
/// search the elements range which match a given value in a sorted dynamic array
// - this method will use the Compare property function for the search
// - returns TRUE and the matching indexes, or FALSE if none found
// - if the array is not sorted, returns FALSE
function FindAllSorted(const Elem; out FirstIndex,LastIndex: Integer): boolean;
/// search for an element value inside a sorted dynamic array
// - this method will use the Compare property function for the search
// - will be faster than a manual FindAndAddIfNotExisting+Sort process
// - returns TRUE and the index of existing Elem, or FALSE and the index
// where the Elem is to be inserted so that the array remains sorted
// - you should then call FastAddSorted() later with the returned Index
// - if the array is not sorted, returns FALSE and Index=-1
// - warning: Elem must be of the same exact type than the dynamic array,
// and must be a reference to a variable (no FastLocateSorted(i+10) e.g.)
function FastLocateSorted(const Elem; out Index: Integer): boolean;
/// insert a sorted element value at the proper place
// - the index should have been computed by FastLocateSorted(): false
// - you may consider using FastLocateOrAddSorted() instead
procedure FastAddSorted(Index: Integer; const Elem);
/// search and add an element value inside a sorted dynamic array
// - this method will use the Compare property function for the search
// - will be faster than a manual FindAndAddIfNotExisting+Sort process
// - returns the index of the existing Elem and wasAdded^=false
// - returns the sorted index of the inserted Elem and wasAdded^=true
// - if the array is not sorted, returns -1 and wasAdded^=false
// - is just a wrapper around FastLocateSorted+FastAddSorted
function FastLocateOrAddSorted(const Elem; wasAdded: PBoolean=nil): integer;
/// delete a sorted element value at the proper place
// - plain Delete(Index) would reset the fSorted flag to FALSE, so use
// this method with a FastLocateSorted/FastAddSorted array
procedure FastDeleteSorted(Index: Integer);
/// will reverse all array elements, in place
procedure Reverse;
/// sort the dynamic array elements using a lookup array of indexes
// - in comparison to the Sort method, this CreateOrderedIndex won't change
// the dynamic array content, but only create (or update) the supplied
// integer lookup array, using the specified comparison function
// - if aCompare is not supplied, the method will use fCompare (if defined)
// - you should provide either a void either a valid lookup table, that is
// a table with one to one lookup (e.g. created with FillIncreasing)
// - if the lookup table has less elements than the main dynamic array,
// its content will be recreated
procedure CreateOrderedIndex(var aIndex: TIntegerDynArray;
aCompare: TDynArraySortCompare); overload;
/// sort the dynamic array elements using a lookup array of indexes
// - this overloaded method will use the supplied TSynTempBuffer for
// index storage, so use PIntegerArray(aIndex.buf) to access the values
// - caller should always make aIndex.Done once done
procedure CreateOrderedIndex(out aIndex: TSynTempBuffer;
aCompare: TDynArraySortCompare); overload;
/// sort using a lookup array of indexes, after a Add()
// - will resize aIndex if necessary, and set aIndex[Count-1] := Count-1
procedure CreateOrderedIndexAfterAdd(var aIndex: TIntegerDynArray;
aCompare: TDynArraySortCompare);
/// save the dynamic array content into a (memory) stream
// - will handle array of binaries values (byte, word, integer...), array of
// strings or array of packed records, with binaries and string properties
// - will use a proprietary binary format, with some variable-length encoding
// of the string length - note that if you change the type definition, any
// previously-serialized content will fail, maybe triggering unexpected GPF:
// use SaveToTypeInfoHash if you share this binary data accross executables
// - Stream position will be set just after the added data
// - is optimized for memory streams, but will work with any kind of TStream
procedure SaveToStream(Stream: TStream);
/// load the dynamic array content from a (memory) stream
// - stream content must have been created using SaveToStream method
// - will handle array of binaries values (byte, word, integer...), array of
// strings or array of packed records, with binaries and string properties
// - will use a proprietary binary format, with some variable-length encoding
// of the string length - note that if you change the type definition, any
// previously-serialized content will fail, maybe triggering unexpected GPF:
// use SaveToTypeInfoHash if you share this binary data accross executables
procedure LoadFromStream(Stream: TCustomMemoryStream);
/// save the dynamic array content into an allocated memory buffer
// - Dest buffer must have been allocated to contain at least the number
// of bytes returned by the SaveToLength method
// - return a pointer at the end of the data written in Dest, nil in case
// of an invalid input buffer
// - will use a proprietary binary format, with some variable-length encoding
// of the string length - note that if you change the type definition, any
// previously-serialized content will fail, maybe triggering unexpected GPF:
// use SaveToTypeInfoHash if you share this binary data accross executables
// - this method will raise an ESynException for T*ObjArray types
// - use TDynArray.LoadFrom or TDynArrayLoadFrom to decode the saved buffer
function SaveTo(Dest: PAnsiChar): PAnsiChar; overload;
/// compute the number of bytes needed by SaveTo() to persist a dynamic array
// - will use a proprietary binary format, with some variable-length encoding
// of the string length - note that if you change the type definition, any
// previously-serialized content will fail, maybe triggering unexpected GPF:
// use SaveToTypeInfoHash if you share this binary data accross executables
// - this method will raise an ESynException for T*ObjArray types
function SaveToLength: integer;
/// save the dynamic array content into a RawByteString
// - will use a proprietary binary format, with some variable-length encoding
// of the string length - note that if you change the type definition, any
// previously-serialized content will fail, maybe triggering unexpected GPF:
// use SaveToTypeInfoHash if you share this binary data accross executables
// - this method will raise an ESynException for T*ObjArray types
// - use TDynArray.LoadFrom or TDynArrayLoadFrom to decode the saved buffer
function SaveTo: RawByteString; overload;
/// compute a crc32c-based hash of the RTTI for this dynamic array
// - can be used to ensure that the TDynArray.SaveTo binary layout
// is compatible accross executables
// - won't include the RTTI type kind, as TypeInfoToHash(), but only
// ElemSize or ElemType information, or any previously registered
// TTextWriter.RegisterCustomJSONSerializerFromText definition
function SaveToTypeInfoHash(crc: cardinal=0): cardinal;
/// unserialize dynamic array content from binary written by TDynArray.SaveTo
// - return nil if the Source buffer is incorrect: invalid type, wrong
// checksum, or optional SourceMax overflow
// - return a non nil pointer just after the Source content on success
// - this method will raise an ESynException for T*ObjArray types
// - you can optionally call AfterEach callback for each row loaded
// - if you don't want to allocate all items on memory, but just want to
// iterate over all items stored in a TDynArray.SaveTo memory buffer,
// consider using TDynArrayLoadFrom object
function LoadFrom(Source: PAnsiChar; AfterEach: TDynArrayAfterLoadFrom=nil;
NoCheckHash: boolean=false; SourceMax: PAnsiChar=nil): PAnsiChar;
/// unserialize the dynamic array content from a TDynArray.SaveTo binary string
// - same as LoadFrom, and will check for any buffer overflow since we
// know the actual end of input buffer
function LoadFromBinary(const Buffer: RawByteString;
NoCheckHash: boolean=false): boolean;
/// serialize the dynamic array content as JSON
// - is just a wrapper around TTextWriter.AddDynArrayJSON()
// - this method will therefore recognize T*ObjArray types
function SaveToJSON(EnumSetsAsText: boolean=false;
reformat: TTextWriterJSONFormat=jsonCompact): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// serialize the dynamic array content as JSON
// - is just a wrapper around TTextWriter.AddDynArrayJSON()
// - this method will therefore recognize T*ObjArray types
procedure SaveToJSON(out Result: RawUTF8; EnumSetsAsText: boolean=false;
reformat: TTextWriterJSONFormat=jsonCompact); overload;
/// load the dynamic array content from an UTF-8 encoded JSON buffer
// - expect the format as saved by TTextWriter.AddDynArrayJSON method, i.e.
// handling TBooleanDynArray, TIntegerDynArray, TInt64DynArray, TCardinalDynArray,
// TDoubleDynArray, TCurrencyDynArray, TWordDynArray, TByteDynArray,
// TRawUTF8DynArray, TWinAnsiDynArray, TRawByteStringDynArray,
// TStringDynArray, TWideStringDynArray, TSynUnicodeDynArray,
// TTimeLogDynArray and TDateTimeDynArray as JSON array - or any customized
// valid JSON serialization as set by TTextWriter.RegisterCustomJSONSerializer
// - or any other kind of array as Base64 encoded binary stream precessed
// via JSON_BASE64_MAGIC (UTF-8 encoded \uFFF0 special code)
// - typical handled content could be
// ! '[1,2,3,4]' or '["\uFFF0base64encodedbinary"]'
// - return a pointer at the end of the data read from P, nil in case
// of an invalid input buffer
// - this method will recognize T*ObjArray types, and will first free
// any existing instance before unserializing, to avoid memory leak
// - warning: the content of P^ will be modified during parsing: please
// make a local copy if it will be needed later (using e.g. TSynTempBufer)
function LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char=nil{$ifndef NOVARIANTS};
CustomVariantOptions: PDocVariantOptions=nil{$endif}): PUTF8Char;
{$ifndef NOVARIANTS}
/// load the dynamic array content from a TDocVariant instance
// - will convert the TDocVariant into JSON, the call LoadFromJSON
function LoadFromVariant(const DocVariant: variant): boolean;
{$endif NOVARIANTS}
/// select a sub-section (slice) of a dynamic array content
procedure Slice(var Dest; aCount: Cardinal; aFirstIndex: cardinal=0);
/// add elements from a given dynamic array variable
// - the supplied source DynArray MUST be of the same exact type as the
// current used for this TDynArray - warning: pass here a reference to
// a "array of ..." variable, not another TDynArray instance; if you
// want to add another TDynArray, use AddDynArray() method
// - you can specify the start index and the number of items to take from
// the source dynamic array (leave as -1 to add till the end)
// - returns the number of items added to the array
function AddArray(const DynArrayVar; aStartIndex: integer=0; aCount: integer=-1): integer;
{$ifndef DELPHI5OROLDER}
/// fast initialize a wrapper for an existing dynamic array of the same type
// - is slightly faster than
// ! Init(aAnother.ArrayType,aValue,nil);
procedure InitFrom(const aAnother: TDynArray; var aValue);
{$ifdef HASINLINE}inline;{$endif}
/// add elements from a given TDynArray
// - the supplied source TDynArray MUST be of the same exact type as the
// current used for this TDynArray, otherwise it won't do anything
// - you can specify the start index and the number of items to take from
// the source dynamic array (leave as -1 to add till the end)
procedure AddDynArray(const aSource: TDynArray; aStartIndex: integer=0; aCount: integer=-1);
/// compare the content of the two arrays, returning TRUE if both match
// - this method compares using any supplied Compare property (unless
// ignorecompare=true), or by content using the RTTI element description
// of the whole array items
// - will call SaveToJSON to compare T*ObjArray kind of arrays
function Equals(const B: TDynArray; ignorecompare: boolean=false): boolean;
/// set all content of one dynamic array to the current array
// - both must be of the same exact type
// - T*ObjArray will be reallocated and copied by content (using a temporary
// JSON serialization), unless ObjArrayByRef is true and pointers are copied
procedure Copy(const Source: TDynArray; ObjArrayByRef: boolean=false);
/// set all content of one dynamic array to the current array
// - both must be of the same exact type
// - T*ObjArray will be reallocated and copied by content (using a temporary
// JSON serialization), unless ObjArrayByRef is true and pointers are copied
procedure CopyFrom(const Source; MaxElem: integer; ObjArrayByRef: boolean=false);
/// set all content of the current dynamic array to another array variable
// - both must be of the same exact type
// - resulting length(Dest) will match the exact items count, even if an
// external Count integer variable is used by this instance
// - T*ObjArray will be reallocated and copied by content (using a temporary
// JSON serialization), unless ObjArrayByRef is true and pointers are copied
procedure CopyTo(out Dest; ObjArrayByRef: boolean=false);
{$endif DELPHI5OROLDER}
/// returns a pointer to an element of the array
// - returns nil if aIndex is out of range
// - since TDynArray is just a wrapper around an existing array, you should
// better use direct access to its wrapped variable, and not using this
// slower and more error prone method (such pointer access lacks of strong
// typing abilities), which was designed for TDynArray internal use
function ElemPtr(index: PtrInt): pointer; {$ifdef HASINLINE}inline;{$endif}
/// will copy one element content from its index into another variable
// - do nothing if index is out of range
procedure ElemCopyAt(index: PtrInt; var Dest); {$ifdef FPC}inline;{$endif}
/// will move one element content from its index into another variable
// - will erase the internal item after copy
// - do nothing if index is out of range
procedure ElemMoveTo(index: PtrInt; var Dest);
/// will copy one variable content into an indexed element
// - do nothing if index is out of range
// - ClearBeforeCopy will call ElemClear() before the copy, which may be safer
// if the source item is a copy of Values[index] with some dynamic arrays
procedure ElemCopyFrom(const Source; index: PtrInt;
ClearBeforeCopy: boolean=false); {$ifdef FPC}inline;{$endif}
/// compare the content of two elements, returning TRUE if both values equal
// - this method compares first using any supplied Compare property,
// then by content using the RTTI element description of the whole record
function ElemEquals(const A,B): boolean;
/// will reset the element content
procedure ElemClear(var Elem);
/// will copy one element content
procedure ElemCopy(const A; var B); {$ifdef FPC}inline;{$endif}
/// will copy the first field value of an array element
// - will use the array KnownType to guess the copy routine to use
// - returns false if the type information is not enough for a safe copy
function ElemCopyFirstField(Source,Dest: Pointer): boolean;
/// save an array element into a serialized binary content
// - use the same layout as TDynArray.SaveTo, but for a single item
// - you can use ElemLoad method later to retrieve its content
// - warning: Elem must be of the same exact type than the dynamic array,
// and must be a reference to a variable (you can't write ElemSave(i+10) e.g.)
function ElemSave(const Elem): RawByteString;
/// load an array element as saved by the ElemSave method into Elem variable
// - warning: Elem must be of the same exact type than the dynamic array,
// and must be a reference to a variable (you can't write ElemLoad(P,i+10) e.g.)
procedure ElemLoad(Source: PAnsiChar; var Elem; SourceMax: PAnsiChar=nil); overload;
/// load an array element as saved by the ElemSave method
// - this overloaded method will retrieve the element as a memory buffer,
// which should be cleared by ElemLoadClear() before release
function ElemLoad(Source: PAnsiChar; SourceMax: PAnsiChar=nil): RawByteString; overload;
/// search for an array element as saved by the ElemSave method
// - same as ElemLoad() + Find()/IndexOf() + ElemLoadClear()
// - will call Find() method if Compare property is set
// - will call generic IndexOf() method if no Compare property is set
function ElemLoadFind(Source: PAnsiChar; SourceMax: PAnsiChar=nil): integer;
/// finalize a temporary buffer used to store an element via ElemLoad()
// - will release any managed type referenced inside the RawByteString,
// then void the variable
// - is just a wrapper around ElemClear(pointer(ElemTemp)) + ElemTemp := ''
procedure ElemLoadClear(var ElemTemp: RawByteString);
/// retrieve or set the number of elements of the dynamic array
// - same as length(DynArray) or SetLength(DynArray)
// - this property will recognize T*ObjArray types, so will free any stored
// instance if the array is sized down
property Count: PtrInt read GetCount write SetCount;
/// the internal buffer capacity
// - if no external Count pointer was set with Init, is the same as Count
// - if an external Count pointer is set, you can set a value to this
// property before a massive use of the Add() method e.g.
// - if no external Count pointer is set, set a value to this property
// will affect the Count value, i.e. Add() will append after this count
// - this property will recognize T*ObjArray types, so will free any stored
// instance if the array is sized down
property Capacity: PtrInt read GetCapacity write SetCapacity;
/// the compare function to be used for Sort and Find methods
// - by default, no comparison function is set
// - common functions exist for base types: e.g. SortDynArrayByte, SortDynArrayBoolean,
// SortDynArrayWord, SortDynArrayInteger, SortDynArrayCardinal, SortDynArraySingle,
// SortDynArrayInt64, SortDynArrayDouble, SortDynArrayAnsiString,
// SortDynArrayAnsiStringI, SortDynArrayString, SortDynArrayStringI,
// SortDynArrayUnicodeString, SortDynArrayUnicodeStringI
property Compare: TDynArraySortCompare read fCompare write SetCompare;
/// must be TRUE if the array is currently in sorted order according to
// the compare function
// - Add/Delete/Insert/Load* methods will reset this property to false
// - Sort method will set this property to true
// - you MUST set this property to false if you modify the dynamic array
// content in your code, so that Find() won't try to wrongly use binary
// search in an unsorted array, and miss its purpose
property Sorted: boolean read fSorted write fSorted;
/// low-level direct access to the storage variable
property Value: PPointer read fValue;
/// the first field recognized type
// - could have been set at initialization, or after a GuessKnownType call
property KnownType: TDynArrayKind read fKnownType;
/// the raw storage size of the first field KnownType
property KnownSize: integer read fKnownSize;
/// the known RTTI information of the whole array
property ArrayType: pointer read fTypeInfo;
/// the known type name of the whole array, as RawUTF8
property ArrayTypeName: RawUTF8 read GetArrayTypeName;
/// the known type name of the whole array, as PShortString
property ArrayTypeShort: PShortString read GetArrayTypeShort;
/// the internal in-memory size of one element, as retrieved from RTTI
property ElemSize: cardinal read fElemSize;
/// the internal type information of one element, as retrieved from RTTI
property ElemType: pointer read fElemType;
/// if this dynamic aray is a T*ObjArray
property IsObjArray: boolean read GetIsObjArray write SetIsObjArray;
end;
/// a pointer to a TDynArray wrapper instance
PDynArray = ^TDynArray;
/// allows to iterate over a TDynArray.SaveTo binary buffer
// - may be used as alternative to TDynArray.LoadFrom, if you don't want
// to allocate all items at once, but retrieve items one by one
TDynArrayLoadFrom = object
protected
DynArray: TDynArray; // used to access RTTI
Hash: PCardinalArray;
PositionEnd: PAnsiChar;
public
/// how many items were saved in the TDynArray.SaveTo binary buffer
// - equals -1 if Init() failed to unserialize its header
Count: integer;
/// the zero-based index of the current item pointed by next Step() call
// - is in range 0..Count-1 until Step() returns false
Current: integer;
/// current position in the TDynArray.SaveTo binary buffer
// - after Step() returned false, points just after the binary buffer,
// like a regular TDynArray.LoadFrom
Position: PAnsiChar;
/// initialize iteration over a TDynArray.SaveTo binary buffer
// - returns true on success, with Count and Position being set
// - returns false if the supplied binary buffer is not correct
// - you can specify an optional SourceMaxLen to avoid any buffer overflow
function Init(ArrayTypeInfo: pointer; Source: PAnsiChar;
SourceMaxLen: PtrInt=0): boolean; overload;
/// initialize iteration over a TDynArray.SaveTo binary buffer
// - returns true on success, with Count and Position being set
// - returns false if the supplied binary buffer is not correct
function Init(ArrayTypeInfo: pointer; const Source: RawByteString): boolean; overload;
/// iterate over the current stored item
// - Elem should point to a variable of the exact item type stored in this
// dynamic array
// - returns true if Elem was filled with one value, or false if all
// items were read, and Position contains the end of the binary buffer
function Step(out Elem): boolean;
/// extract the first field value of the current stored item
// - returns true if Field was filled with one value, or false if all
// items were read, and Position contains the end of the binary buffer
// - could be called before Step(), to pre-allocate a new item instance,
// or update an existing instance
function FirstField(out Field): boolean;
/// after all items are read by Step(), validate the stored hash
// - returns true if items hash is correct, false otherwise
function CheckHash: boolean;
end;
/// function prototype to be used for hashing of a dynamic array element
// - this function must use the supplied hasher on the Elem data
TDynArrayHashOne = function(const Elem; Hasher: THasher): cardinal;
/// event handler to be used for hashing of a dynamic array element
// - can be set as an alternative to TDynArrayHashOne
TEventDynArrayHashOne = function(const Elem): cardinal of object;
{.$define DYNARRAYHASHCOLLISIONCOUNT}
/// allow O(1) lookup to any dynamic array content
// - this won't handle the storage process (like add/update), just efficiently
// maintain a hash table over an existing dynamic array: several TDynArrayHasher
// could be applied to a single TDynArray wrapper
// - TDynArrayHashed will use a TDynArrayHasher for its own store
{$ifdef USERECORDWITHMETHODS}TDynArrayHasher = record
{$else}TDynArrayHasher = object {$endif}
private
DynArray: PDynArray;
HashElement: TDynArrayHashOne;
EventHash: TEventDynArrayHashOne;
Hasher: THasher;
HashTable: TIntegerDynArray; // store 0 for void entry, or Index+1
HashTableSize: integer;
ScanCounter: integer; // Scan()>=0 up to CountTrigger*2
State: set of (hasHasher, canHash);
function HashTableIndex(aHashCode: cardinal): cardinal; {$ifdef HASINLINE}inline;{$endif}
procedure HashAdd(aHashCode: cardinal; var result: integer);
procedure HashDelete(aArrayIndex, aHashTableIndex: integer; aHashCode: cardinal);
procedure RaiseFatalCollision(const caller: RawUTF8; aHashCode: cardinal);
public
/// associated item comparison - may differ from DynArray^.Compare
Compare: TDynArraySortCompare;
/// custom method-based comparison function
EventCompare: TEventDynArraySortCompare;
/// after how many FindBeforeAdd() or Scan() the hashing starts - default 32
CountTrigger: integer;
{$ifdef DYNARRAYHASHCOLLISIONCOUNT}
/// low-level access to an hash collisions counter
FindCollisions: cardinal;
{$endif}
/// initialize the hash table for a given dynamic array storage
// - you can call this method several times, e.g. if aCaseInsensitive changed
procedure Init(aDynArray: PDynArray; aHashElement: TDynArrayHashOne;
aEventHash: TEventDynArrayHashOne; aHasher: THasher; aCompare: TDynArraySortCompare;
aEventCompare: TEventDynArraySortCompare; aCaseInsensitive: boolean);
/// initialize a known hash table for a given dynamic array storage
// - you can call this method several times, e.g. if aCaseInsensitive changed
procedure InitSpecific(aDynArray: PDynArray; aKind: TDynArrayKind; aCaseInsensitive: boolean);
/// allow custom hashing via a method event
procedure SetEventHash(const event: TEventDynArrayHashOne);
/// search for an element value inside the dynamic array without hashing
// - trigger hashing if ScanCounter reaches CountTrigger*2
function Scan(Elem: pointer): integer;
/// search for an element value inside the dynamic array with hashing
function Find(Elem: pointer): integer; overload;
/// search for a hashed element value inside the dynamic array with hashing
function Find(Elem: pointer; aHashCode: cardinal): integer; overload;
/// search for a hash position inside the dynamic array with hashing
function Find(aHashCode: cardinal; aForAdd: boolean): integer; overload;
/// returns position in array, or next void index in HashTable[] as -(index+1)
function FindOrNew(aHashCode: cardinal; Elem: pointer; aHashTableIndex: PInteger=nil): integer;
/// search an hashed element value for adding, updating the internal hash table
// - trigger hashing if Count reaches CountTrigger
function FindBeforeAdd(Elem: pointer; out wasAdded: boolean; aHashCode: cardinal): integer;
/// search and delete an element value, updating the internal hash table
function FindBeforeDelete(Elem: pointer): integer;
/// reset the hash table - no rehash yet
procedure Clear;
/// full computation of the internal hash table
// - returns the number of duplicated values found
function ReHash(forced: boolean): integer;
/// compute the hash of a given item
function HashOne(Elem: pointer): cardinal; {$ifdef FPC_OR_DELPHIXE4}inline;{$endif}
{ not inlined to circumvent Delphi 2007=C1632, 2010=C1872, XE3=C2130 }
/// retrieve the low-level hash of a given item
function GetHashFromIndex(aIndex: PtrInt): cardinal;
end;
/// pointer to a TDynArrayHasher instance
PDynArrayHasher = ^TDynArrayHasher;
/// used to access any dynamic arrray elements using fast hash
// - by default, binary sort could be used for searching items for TDynArray:
// using a hash is faster on huge arrays for implementing a dictionary
// - in this current implementation, modification (update or delete) of an
// element is not handled yet: you should rehash all content - only
// TDynArrayHashed.FindHashedForAdding / FindHashedAndUpdate /
// FindHashedAndDelete will refresh the internal hash
// - this object extends the TDynArray type, since presence of Hashs[] dynamic
// array will increase code size if using TDynArrayHashed instead of TDynArray
// - in order to have the better performance, you should use an external Count
// variable, AND set the Capacity property to the expected maximum count (this
// will avoid most ReHash calls for FindHashedForAdding+FindHashedAndUpdate)
{$ifdef UNDIRECTDYNARRAY}
TDynArrayHashed = record
// pseudo inheritance for most used methods
private
function GetCount: PtrInt; inline;
procedure SetCount(aCount: PtrInt) ; inline;
procedure SetCapacity(aCapacity: PtrInt); inline;
function GetCapacity: PtrInt; inline;
public
InternalDynArray: TDynArray;
function Value: PPointer; inline;
function ElemSize: PtrUInt; inline;
function ElemType: Pointer; inline;
function KnownType: TDynArrayKind; inline;
procedure Clear; inline;
procedure ElemCopy(const A; var B); inline;
function ElemPtr(index: PtrInt): pointer; inline;
procedure ElemCopyAt(index: PtrInt; var Dest); inline;
// warning: you shall call ReHash() after manual Add/Delete
function Add(const Elem): integer; inline;
procedure Delete(aIndex: PtrInt); inline;
function SaveTo: RawByteString; overload; inline;
function SaveTo(Dest: PAnsiChar): PAnsiChar; overload; inline;
function SaveToJSON(EnumSetsAsText: boolean=false;
reformat: TTextWriterJSONFormat=jsonCompact): RawUTF8; inline;
procedure Sort(aCompare: TDynArraySortCompare=nil); inline;
function LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char=nil{$ifndef NOVARIANTS};
CustomVariantOptions: PDocVariantOptions=nil{$endif}): PUTF8Char; inline;
function SaveToLength: integer; inline;
function LoadFrom(Source: PAnsiChar; AfterEach: TDynArrayAfterLoadFrom=nil;
NoCheckHash: boolean=false; SourceMax: PAnsiChar=nil): PAnsiChar; inline;
function LoadFromBinary(const Buffer: RawByteString;
NoCheckHash: boolean=false): boolean; inline;
procedure CreateOrderedIndex(var aIndex: TIntegerDynArray;
aCompare: TDynArraySortCompare);
property Count: PtrInt read GetCount write SetCount;
property Capacity: PtrInt read GetCapacity write SetCapacity;
private
{$else UNDIRECTDYNARRAY}
TDynArrayHashed = object(TDynArray)
protected
{$endif UNDIRECTDYNARRAY}
fHash: TDynArrayHasher;
procedure SetEventHash(const event: TEventDynArrayHashOne); {$ifdef HASINLINE}inline;{$endif}
function GetHashFromIndex(aIndex: PtrInt): Cardinal; {$ifdef HASINLINE}inline;{$endif}
public
/// initialize the wrapper with a one-dimension dynamic array
// - this version accepts some hash-dedicated parameters: aHashElement to
// set how to hash each element, aCompare to handle hash collision
// - if no aHashElement is supplied, it will hash according to the RTTI, i.e.
// strings or binary types, and the first field for records (strings included)
// - if no aCompare is supplied, it will use default Equals() method
// - if no THasher function is supplied, it will use the one supplied in
// DefaultHasher global variable, set to crc32c() by default - using
// SSE4.2 instruction if available
// - if CaseInsensitive is set to TRUE, it will ignore difference in 7 bit
// alphabetic characters (e.g. compare 'a' and 'A' as equal)
procedure Init(aTypeInfo: pointer; var aValue;
aHashElement: TDynArrayHashOne=nil; aCompare: TDynArraySortCompare=nil;
aHasher: THasher=nil; aCountPointer: PInteger=nil; aCaseInsensitive: boolean=false);
/// initialize the wrapper with a one-dimension dynamic array
// - this version accepts to specify how both hashing and comparison should
// occur, setting the TDynArrayKind kind of first/hashed field
// - djNone and djCustom are too vague, and will raise an exception
// - no RTTI check is made over the corresponding array layout: you shall
// ensure that aKind matches the dynamic array element definition
// - aCaseInsensitive will be used for djRawUTF8..djHash512 text comparison
procedure InitSpecific(aTypeInfo: pointer; var aValue; aKind: TDynArrayKind;
aCountPointer: PInteger=nil; aCaseInsensitive: boolean=false);
/// will compute all hash from the current elements of the dynamic array
// - is called within the TDynArrayHashed.Init method to initialize the
// internal hash array
// - can be called on purpose, when modifications have been performed on
// the dynamic array content (e.g. in case of element deletion or update,
// or after calling LoadFrom/Clear method) - this is not necessary after
// FindHashedForAdding / FindHashedAndUpdate / FindHashedAndDelete methods
// - returns the number of duplicated items found - which won't be available
// by hashed FindHashed() by definition
function ReHash(forAdd: boolean=false): integer;
/// search for an element value inside the dynamic array using hashing
// - Elem should be of the type expected by both the hash function and
// Equals/Compare methods: e.g. if the searched/hashed field in a record is
// a string as first field, you can safely use a string variable as Elem
// - Elem must refer to a variable: e.g. you can't write FindHashed(i+10)
// - will call fHashElement(Elem,fHasher) to compute the needed hash
// - returns -1 if not found, or the index in the dynamic array if found
function FindHashed(const Elem): integer;
/// search for an element value inside the dynamic array using its hash
// - returns -1 if not found, or the index in the dynamic array if found
// - aHashCode parameter constains an already hashed value of the item,
// to be used e.g. after a call to HashFind()
function FindFromHash(const Elem; aHashCode: cardinal): integer;
/// search for an element value inside the dynamic array using hashing, and
// fill Elem with the found content
// - return the index found (0..Count-1), or -1 if Elem was not found
// - ElemToFill should be of the type expected by the dynamic array, since
// all its fields will be set on match
function FindHashedAndFill(var ElemToFill): integer;
/// search for an element value inside the dynamic array using hashing, and
// add a void entry to the array if was not found (unless noAddEntry is set)
// - this method will use hashing for fast retrieval
// - Elem should be of the type expected by both the hash function and
// Equals/Compare methods: e.g. if the searched/hashed field in a record is
// a string as first field, you can safely use a string variable as Elem
// - returns either the index in the dynamic array if found (and set wasAdded
// to false), either the newly created index in the dynamic array (and set
// wasAdded to true)
// - for faster process (avoid ReHash), please set the Capacity property
// - warning: in contrast to the Add() method, if an entry is added to the
// array (wasAdded=true), the entry is left VOID: you must set the field
// content to expecting value - in short, Elem is used only for searching,
// not copied to the newly created entry in the array - check
// FindHashedAndUpdate() for a method actually copying Elem fields
function FindHashedForAdding(const Elem; out wasAdded: boolean;
noAddEntry: boolean=false): integer; overload;
/// search for an element value inside the dynamic array using hashing, and
// add a void entry to the array if was not found (unless noAddEntry is set)
// - overloaded method acepting an already hashed value of the item, to be used
// e.g. after a call to HashFind()
function FindHashedForAdding(const Elem; out wasAdded: boolean;
aHashCode: cardinal; noAddEntry: boolean=false): integer; overload;
/// ensure a given element name is unique, then add it to the array
// - expected element layout is to have a RawUTF8 field at first position
// - the aName is searched (using hashing) to be unique, and if not the case,
// an ESynException.CreateUTF8() is raised with the supplied arguments
// - use internaly FindHashedForAdding method
// - this version will set the field content with the unique value
// - returns a pointer to the newly added element (to set other fields)
function AddUniqueName(const aName: RawUTF8; const ExceptionMsg: RawUTF8;
const ExceptionArgs: array of const; aNewIndex: PInteger=nil): pointer; overload;
/// ensure a given element name is unique, then add it to the array
// - just a wrapper to AddUniqueName(aName,'',[],aNewIndex)
function AddUniqueName(const aName: RawUTF8; aNewIndex: PInteger=nil): pointer; overload;
/// search for a given element name, make it unique, and add it to the array
// - expected element layout is to have a RawUTF8 field at first position
// - the aName is searched (using hashing) to be unique, and if not the case,
// some suffix is added to make it unique
// - use internaly FindHashedForAdding method
// - this version will set the field content with the unique value
// - returns a pointer to the newly added element (to set other fields)
function AddAndMakeUniqueName(aName: RawUTF8): pointer;
/// search for an element value inside the dynamic array using hashing, then
// update any matching item, or add the item if none matched
// - by design, hashed field shouldn't have been modified by this update,
// otherwise the method won't be able to find and update the old hash: in
// this case, you should first call FindHashedAndDelete(OldElem) then
// FindHashedForAdding(NewElem) to properly handle the internal hash table
// - if AddIfNotExisting is FALSE, returns the index found (0..Count-1),
// or -1 if Elem was not found - update will force slow rehash all content
// - if AddIfNotExisting is TRUE, returns the index found (0..Count-1),
// or the index newly created/added is the Elem value was not matching -
// add won't rehash all content - for even faster process (avoid ReHash),
// please set the Capacity property
// - Elem should be of the type expected by the dynamic array, since its
// content will be copied into the dynamic array, and it must refer to a
// variable: e.g. you can't write FindHashedAndUpdate(i+10)
function FindHashedAndUpdate(const Elem; AddIfNotExisting: boolean): integer;
/// search for an element value inside the dynamic array using hashing, and
// delete it if matchs
// - return the index deleted (0..Count-1), or -1 if Elem was not found
// - can optionally copy the deleted item to FillDeleted^ before erased
// - Elem should be of the type expected by both the hash function and
// Equals/Compare methods, and must refer to a variable: e.g. you can't
// write FindHashedAndDelete(i+10)
// - it won't call slow ReHash but refresh the hash table as needed
function FindHashedAndDelete(const Elem; FillDeleted: pointer=nil;
noDeleteEntry: boolean=false): integer;
/// will search for an element value inside the dynamic array without hashing
// - is used internally when Count < HashCountTrigger
// - is preferred to Find(), since EventCompare would be used if defined
// - Elem should be of the type expected by both the hash function and
// Equals/Compare methods, and must refer to a variable: e.g. you can't
// write Scan(i+10)
// - returns -1 if not found, or the index in the dynamic array if found
// - an internal algorithm can switch to hashing if Scan() is called often,
// even if the number of items is lower than HashCountTrigger
function Scan(const Elem): integer;
/// retrieve the hash value of a given item, from its index
property Hash[aIndex: PtrInt]: Cardinal read GetHashFromIndex;
/// alternative event-oriented Compare function to be used for Sort and Find
// - will be used instead of Compare, to allow object-oriented callbacks
property EventCompare: TEventDynArraySortCompare read fHash.EventCompare write fHash.EventCompare;
/// custom hash function to be used for hashing of a dynamic array element
property HashElement: TDynArrayHashOne read fHash.HashElement;
/// alternative event-oriented Hash function for ReHash
// - this object-oriented callback will be used instead of HashElement
// on each dynamic array entries - HashElement will still be used on
// const Elem values, since they may be just a sub part of the stored entry
property EventHash: TEventDynArrayHashOne read fHash.EventHash write SetEventHash;
/// after how many items the hashing take place
// - for smallest arrays, O(n) search if faster than O(1) hashing, since
// maintaining internal hash table has some CPU and memory costs
// - internal search is able to switch to hashing if it founds out that it
// may have some benefit, e.g. if Scan() is called 2*HashCountTrigger times
// - equals 32 by default, i.e. start hashing when Count reaches 32 or
// manual Scan() is called 64 times
property HashCountTrigger: integer read fHash.CountTrigger write fHash.CountTrigger;
/// access to the internal hash table
// - you can call e.g. Hasher.Clear to invalidate the whole hash table
property Hasher: TDynArrayHasher read fHash;
end;
/// defines a wrapper interface around a dynamic array of TObject
// - implemented by TObjectDynArrayWrapper for instance
// - i.e. most common methods are available to work with a dynamic array
// - warning: the IObjectDynArray MUST be defined in the stack, class or
// record BEFORE the dynamic array it is wrapping, otherwise you may leak
// memory - see for instance TSQLRestServer class:
// ! fSessionAuthentications: IObjectDynArray; // defined before the array
// ! fSessionAuthentication: TSQLRestServerAuthenticationDynArray;
// note that allocation time as variable on the local stack may depend on the
// compiler, and its optimization
IObjectDynArray = interface
['{A0D50BD0-0D20-4552-B365-1D63393511FC}']
/// search one element within the TObject instances
function Find(Instance: TObject): integer;
/// add one element to the dynamic array of TObject instances
// - once added, the Instance will be owned by this TObjectDynArray instance
function Add(Instance: TObject): integer;
/// delete one element from the TObject dynamic array
// - deleted TObject instance will be freed as expected
procedure Delete(Index: integer);
/// sort the dynamic array content according to a specified comparer
procedure Sort(Compare: TDynArraySortCompare);
/// delete all TObject instances, and release the memory
// - is not to be called for most use, thanks to reference-counting memory
// handling, but can be handy for quick release
procedure Clear;
/// ensure the internal list capacity is set to the current Count
// - may be used to publish the associated dynamic array with the expected
// final size, once IObjectDynArray is out of scope
procedure Slice;
/// returns the number of TObject instances available
// - note that the length of the associated dynamic array is used to store
// the capacity of the list, so won't probably never match with this value
function Count: integer;
/// returns the internal array capacity of TObject instances available
// - which is in fact the length() of the associated dynamic array
function Capacity: integer;
end;
/// a wrapper to own a dynamic array of TObject
// - this version behave list a TObjectList (i.e. owning the class instances)
// - but the dynamic array is NOT owned by the instance
// - will define an internal Count property, using the dynamic array length
// as capacity: adding and deleting will be much faster
// - implements IObjectDynArray, so that most common methods are available
// to work with the dynamic array
// - does not need any sub-classing of generic overhead to work, and will be
// reference counted
// - warning: the IObjectDynArray MUST be defined in the stack, class or
// record BEFORE the dynamic array it is wrapping, otherwise you may leak
// memory, and TObjectDynArrayWrapper.Destroy will raise an ESynException
// - warning: issues with Delphi 10.4 Sydney were reported, which seemed to
// change the order of fields finalization, so the whole purpose of this
// wrapper may have become incompatible with Delphi 10.4 and up
// - a sample usage may be:
// !var DA: IObjectDynArray; // defined BEFORE the dynamic array itself
// ! A: array of TMyObject;
// ! i: integer;
// !begin
// ! DA := TObjectDynArrayWrapper.Create(A);
// ! DA.Add(TMyObject.Create('one'));
// ! DA.Add(TMyObject.Create('two'));
// ! DA.Delete(0);
// ! assert(DA.Count=1);
// ! assert(A[0].Name='two');
// ! DA.Clear;
// ! assert(DA.Count=0);
// ! DA.Add(TMyObject.Create('new'));
// ! assert(DA.Count=1);
// !end; // will auto-release DA (no need of try..finally DA.Free)
TObjectDynArrayWrapper = class(TInterfacedObject, IObjectDynArray)
protected
fValue: PPointer;
fCount: integer;
fOwnObjects: boolean;
public
/// initialize the wrapper with a one-dimension dynamic array of TObject
// - by default, objects will be owned by this class, but you may set
// aOwnObjects=false if you expect the dynamic array to remain available
constructor Create(var aValue; aOwnObjects: boolean=true);
/// will release all associated TObject instances
destructor Destroy; override;
/// search one element within the TObject instances
function Find(Instance: TObject): integer;
/// add one element to the dynamic array of TObject instances
// - once added, the Instance will be owned by this TObjectDynArray instance
// (unless aOwnObjects was false in Create)
function Add(Instance: TObject): integer;
/// delete one element from the TObject dynamic array
// - deleted TObject instance will be freed as expected (unless aOwnObjects
// was defined as false in Create)
procedure Delete(Index: integer);
/// sort the dynamic array content according to a specified comparer
procedure Sort(Compare: TDynArraySortCompare);
/// delete all TObject instances, and release the memory
// - is not to be called for most use, thanks to reference-counting memory
// handling, but can be handy for quick release
// - warning: won't release the instances if aOwnObjects was false in Create
procedure Clear;
/// ensure the internal list capacity is set to the current Count
// - may be used to publish the associated dynamic array with the expected
// final size, once IObjectDynArray is out of scope
procedure Slice;
/// returns the number of TObject instances available
// - note that the length() of the associated dynamic array is used to store
// the capacity of the list, so won't probably never match with this value
function Count: integer;
/// returns the internal array capacity of TObject instances available
// - which is in fact the length() of the associated dynamic array
function Capacity: integer;
end;
/// abstract parent class with a virtual constructor, ready to be overridden
// to initialize the instance
// - you can specify such a class if you need an object including published
// properties (like TPersistent) with a virtual constructor (e.g. to
// initialize some nested class properties)
TPersistentWithCustomCreate = class(TPersistent)
public
/// this virtual constructor will be called at instance creation
// - this constructor does nothing, but is declared as virtual so that
// inherited classes may safely override this default void implementation
constructor Create; virtual;
end;
{$M+}
/// abstract parent class with threadsafe implementation of IInterface and
// a virtual constructor
// - you can specify e.g. such a class to TSQLRestServer.ServiceRegister() if
// you need an interfaced object with a virtual constructor, ready to be
// overridden to initialize the instance
TInterfacedObjectWithCustomCreate = class(TInterfacedObject)
public
/// this virtual constructor will be called at instance creation
// - this constructor does nothing, but is declared as virtual so that
// inherited classes may safely override this default void implementation
constructor Create; virtual;
/// used to mimic TInterfacedObject reference counting
// - Release=true will call TInterfacedObject._Release
// - Release=false will call TInterfacedObject._AddRef
// - could be used to emulate proper reference counting of the instance
// via interfaces variables, but still storing plain class instances
// (e.g. in a global list of instances)
procedure RefCountUpdate(Release: boolean); virtual;
end;
/// our own empowered TPersistent-like parent class
// - TPersistent has an unexpected speed overhead due a giant lock introduced
// to manage property name fixup resolution (which we won't use outside the VCL)
// - this class has a virtual constructor, so is a preferred alternative
// to both TPersistent and TPersistentWithCustomCreate classes
// - for best performance, any type inheriting from this class will bypass
// some regular steps: do not implement interfaces or use TMonitor with them!
TSynPersistent = class(TObject)
protected
// this default implementation will call AssignError()
procedure AssignTo(Dest: TSynPersistent); virtual;
procedure AssignError(Source: TSynPersistent);
public
/// this virtual constructor will be called at instance creation
// - this constructor does nothing, but is declared as virtual so that
// inherited classes may safely override this default void implementation
constructor Create; virtual;
/// allows to implement a TPersistent-like assignement mechanism
// - inherited class should override AssignTo() protected method
// to implement the proper assignment
procedure Assign(Source: TSynPersistent); virtual;
/// optimized initialization code
// - somewhat faster than the regular RTL implementation - especially
// since rewritten in pure asm on Delphi/x86
// - warning: this optimized version won't initialize the vmtIntfTable
// for this class hierarchy: as a result, you would NOT be able to
// implement an interface with a TSynPersistent descendent (but you should
// not need to, but inherit from TInterfacedObject)
// - warning: under FPC, it won't initialize fields management operators
class function NewInstance: TObject; override;
{$ifndef FPC_OR_PUREPASCAL}
/// optimized x86 asm finalization code
// - warning: this version won't release either any allocated TMonitor
// (as available since Delphi 2009) - do not use TMonitor with
// TSynPersistent, but rather the faster TSynPersistentLock class
procedure FreeInstance; override;
{$endif}
end;
{$M-}
/// simple and efficient TList, without any notification
// - regular TList has an internal notification mechanism which slows down
// basic process, and most used methods were not defined as virtual, so can't
// be easily inherited
// - stateless methods (like Add/Clear/Exists/Remove) are defined as virtual
// since can be overriden e.g. by TSynObjectListLocked to add a TSynLocker
TSynList = class(TSynPersistent)
protected
fCount: integer;
fList: TPointerDynArray;
function Get(index: Integer): pointer; {$ifdef HASINLINE} inline; {$endif}
public
/// add one item to the list
function Add(item: pointer): integer; virtual;
/// delete all items of the list
procedure Clear; virtual;
/// delete one item from the list
procedure Delete(index: integer); virtual;
/// fast retrieve one item in the list
function IndexOf(item: pointer): integer; virtual;
/// fast check if one item exists in the list
function Exists(item: pointer): boolean; virtual;
/// fast delete one item in the list
function Remove(item: pointer): integer; virtual;
/// how many items are stored in this TList instance
property Count: integer read fCount;
/// low-level access to the items stored in this TList instance
property List: TPointerDynArray read fList;
/// low-level array-like access to the items stored in this TList instance
// - warning: if index is out of range, will return nil and won't raise
// any exception
property Items[index: Integer]: pointer read Get; default;
end;
/// simple and efficient TObjectList, without any notification
TSynObjectList = class(TSynList)
protected
fOwnObjects: boolean;
public
/// initialize the object list
constructor Create(aOwnObjects: boolean=true); reintroduce;
/// delete one object from the list
procedure Delete(index: integer); override;
/// delete all objects of the list
procedure Clear; override;
/// delete all objects of the list in reverse order
// - for some kind of processes, owned objects should be removed from the
// last added to the first
procedure ClearFromLast; virtual;
/// finalize the store items
destructor Destroy; override;
end;
/// allow to add cross-platform locking methods to any class instance
// - typical use is to define a Safe: TSynLocker property, call Safe.Init
// and Safe.Done in constructor/destructor methods, and use Safe.Lock/UnLock
// methods in a try ... finally section
// - in respect to the TCriticalSection class, fix a potential CPU cache line
// conflict which may degrade the multi-threading performance, as reported by
// @http://www.delphitools.info/2011/11/30/fixing-tcriticalsection
// - internal padding is used to safely store up to 7 values protected
// from concurrent access with a mutex, so that SizeOf(TSynLocker)>128
// - for object-level locking, see TSynPersistentLock which owns one such
// instance, or call low-level fSafe := NewSynLocker in your constructor,
// then fSafe^.DoneAndFreemem in your destructor
TSynLocker = object
protected
fSection: TRTLCriticalSection;
fLockCount: integer;
fInitialized: boolean;
{$ifndef NOVARIANTS}
function GetVariant(Index: integer): Variant;
procedure SetVariant(Index: integer; const Value: Variant);
function GetInt64(Index: integer): Int64;
procedure SetInt64(Index: integer; const Value: Int64);
function GetBool(Index: integer): boolean;
procedure SetBool(Index: integer; const Value: boolean);
function GetUnlockedInt64(Index: integer): Int64;
procedure SetUnlockedInt64(Index: integer; const Value: Int64);
function GetPointer(Index: integer): Pointer;
procedure SetPointer(Index: integer; const Value: Pointer);
function GetUTF8(Index: integer): RawUTF8;
procedure SetUTF8(Index: integer; const Value: RawUTF8);
function GetIsLocked: boolean; {$ifdef HASINLINE}inline;{$endif}
{$endif NOVARIANTS}
public
/// number of values stored in the internal Padding[] array
// - equals 0 if no value is actually stored, or a 1..7 number otherwise
// - you should not have to use this field, but for optimized low-level
// direct access to Padding[] values, within a Lock/UnLock safe block
PaddingUsedCount: integer;
/// internal padding data, also used to store up to 7 variant values
// - this memory buffer will ensure no CPU cache line mixup occurs
// - you should not use this field directly, but rather the Locked[],
// LockedInt64[], LockedUTF8[] or LockedPointer[] methods
// - if you want to access those array values, ensure you protect them
// using a Safe.Lock; try ... Padding[n] ... finally Safe.Unlock structure,
// and maintain the PaddingUsedCount field accurately
Padding: array[0..6] of TVarData;
/// initialize the mutex
// - calling this method is mandatory (e.g. in the class constructor owning
// the TSynLocker instance), otherwise you may encounter unexpected
// behavior, like access violations or memory leaks
procedure Init;
/// finalize the mutex
// - calling this method is mandatory (e.g. in the class destructor owning
// the TSynLocker instance), otherwise you may encounter unexpected
// behavior, like access violations or memory leaks
procedure Done;
/// finalize the mutex, and call FreeMem() on the pointer of this instance
// - should have been initiazed with a NewSynLocker call
procedure DoneAndFreeMem;
/// lock the instance for exclusive access
// - this method is re-entrant from the same thread (you can nest Lock/UnLock
// calls in the same thread), but would block any other Lock attempt in
// another thread
// - use as such to avoid race condition (from a Safe: TSynLocker property):
// ! Safe.Lock;
// ! try
// ! ...
// ! finally
// ! Safe.Unlock;
// ! end;
procedure Lock; {$ifdef HASINLINE}inline;{$endif}
/// will try to acquire the mutex
// - use as such to avoid race condition (from a Safe: TSynLocker property):
// ! if Safe.TryLock then
// ! try
// ! ...
// ! finally
// ! Safe.Unlock;
// ! end;
function TryLock: boolean; {$ifdef HASINLINE}inline;{$endif}
/// will try to acquire the mutex for a given time
// - use as such to avoid race condition (from a Safe: TSynLocker property):
// ! if Safe.TryLockMS(100) then
// ! try
// ! ...
// ! finally
// ! Safe.Unlock;
// ! end;
function TryLockMS(retryms: integer): boolean;
/// release the instance for exclusive access
// - each Lock/TryLock should have its exact UnLock opposite, so a
// try..finally block is mandatory for safe code
procedure UnLock; {$ifdef HASINLINE}inline;{$endif}
/// will enter the mutex until the IUnknown reference is released
// - could be used as such under Delphi:
// !begin
// ! ... // unsafe code
// ! Safe.ProtectMethod;
// ! ... // thread-safe code
// !end; // local hidden IUnknown will release the lock for the method
// - warning: under FPC, you should assign its result to a local variable -
// see bug http://bugs.freepascal.org/view.php?id=26602
// !var LockFPC: IUnknown;
// !begin
// ! ... // unsafe code
// ! LockFPC := Safe.ProtectMethod;
// ! ... // thread-safe code
// !end; // LockFPC will release the lock for the method
// or
// !begin
// ! ... // unsafe code
// ! with Safe.ProtectMethod do begin
// ! ... // thread-safe code
// ! end; // local hidden IUnknown will release the lock for the method
// !end;
function ProtectMethod: IUnknown;
/// returns true if the mutex is currently locked by another thread
property IsLocked: boolean read GetIsLocked;
/// returns true if the Init method has been called for this mutex
// - is only relevant if the whole object has been previously filled with 0,
// i.e. as part of a class or as global variable, but won't be accurate
// when allocated on stack
property IsInitialized: boolean read fInitialized;
{$ifndef NOVARIANTS}
/// safe locked access to a Variant value
// - you may store up to 7 variables, using an 0..6 index, shared with
// LockedBool, LockedInt64, LockedPointer and LockedUTF8 array properties
// - returns null if the Index is out of range
property Locked[Index: integer]: Variant read GetVariant write SetVariant;
/// safe locked access to a Int64 value
// - you may store up to 7 variables, using an 0..6 index, shared with
// Locked and LockedUTF8 array properties
// - Int64s will be stored internally as a varInt64 variant
// - returns nil if the Index is out of range, or does not store a Int64
property LockedInt64[Index: integer]: Int64 read GetInt64 write SetInt64;
/// safe locked access to a boolean value
// - you may store up to 7 variables, using an 0..6 index, shared with
// Locked, LockedInt64, LockedPointer and LockedUTF8 array properties
// - value will be stored internally as a varBoolean variant
// - returns nil if the Index is out of range, or does not store a boolean
property LockedBool[Index: integer]: boolean read GetBool write SetBool;
/// safe locked access to a pointer/TObject value
// - you may store up to 7 variables, using an 0..6 index, shared with
// Locked, LockedBool, LockedInt64 and LockedUTF8 array properties
// - pointers will be stored internally as a varUnknown variant
// - returns nil if the Index is out of range, or does not store a pointer
property LockedPointer[Index: integer]: Pointer read GetPointer write SetPointer;
/// safe locked access to an UTF-8 string value
// - you may store up to 7 variables, using an 0..6 index, shared with
// Locked and LockedPointer array properties
// - UTF-8 string will be stored internally as a varString variant
// - returns '' if the Index is out of range, or does not store a string
property LockedUTF8[Index: integer]: RawUTF8 read GetUTF8 write SetUTF8;
/// safe locked in-place increment to an Int64 value
// - you may store up to 7 variables, using an 0..6 index, shared with
// Locked and LockedUTF8 array properties
// - Int64s will be stored internally as a varInt64 variant
// - returns the newly stored value
// - if the internal value is not defined yet, would use 0 as default value
function LockedInt64Increment(Index: integer; const Increment: Int64): Int64;
/// safe locked in-place exchange of a Variant value
// - you may store up to 7 variables, using an 0..6 index, shared with
// Locked and LockedUTF8 array properties
// - returns the previous stored value, or null if the Index is out of range
function LockedExchange(Index: integer; const Value: variant): variant;
/// safe locked in-place exchange of a pointer/TObject value
// - you may store up to 7 variables, using an 0..6 index, shared with
// Locked and LockedUTF8 array properties
// - pointers will be stored internally as a varUnknown variant
// - returns the previous stored value, nil if the Index is out of range,
// or does not store a pointer
function LockedPointerExchange(Index: integer; Value: pointer): pointer;
/// unsafe access to a Int64 value
// - you may store up to 7 variables, using an 0..6 index, shared with
// Locked and LockedUTF8 array properties
// - Int64s will be stored internally as a varInt64 variant
// - returns nil if the Index is out of range, or does not store a Int64
// - you should rather call LockedInt64[] property, or use this property
// with a Lock; try ... finally UnLock block
property UnlockedInt64[Index: integer]: Int64 read GetUnlockedInt64 write SetUnlockedInt64;
{$endif NOVARIANTS}
end;
PSynLocker = ^TSynLocker;
/// adding locking methods to a TSynPersistent with virtual constructor
// - you may use this class instead of the RTL TCriticalSection, since it
// would use a TSynLocker which does not suffer from CPU cache line conflit
TSynPersistentLock = class(TSynPersistent)
protected
fSafe: PSynLocker; // TSynLocker would increase inherited fields offset
public
/// initialize the instance, and its associated lock
constructor Create; override;
/// finalize the instance, and its associated lock
destructor Destroy; override;
/// access to the associated instance critical section
// - call Safe.Lock/UnLock to protect multi-thread access on this storage
property Safe: PSynLocker read fSafe;
end;
/// used for backward compatibility only with existing code
TSynPersistentLocked = class(TSynPersistentLock);
/// adding locking methods to a TInterfacedObject with virtual constructor
TInterfacedObjectLocked = class(TInterfacedObjectWithCustomCreate)
protected
fSafe: PSynLocker; // TSynLocker would increase inherited fields offset
public
/// initialize the object instance, and its associated lock
constructor Create; override;
/// release the instance (including the locking resource)
destructor Destroy; override;
/// access to the locking methods of this instance
// - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block
property Safe: PSynLocker read fSafe;
end;
/// used to determine the exact class type of a TInterfacedObjectWithCustomCreate
// - could be used to create instances using its virtual constructor
TInterfacedObjectWithCustomCreateClass = class of TInterfacedObjectWithCustomCreate;
/// used to determine the exact class type of a TPersistentWithCustomCreateClass
// - could be used to create instances using its virtual constructor
TPersistentWithCustomCreateClass = class of TPersistentWithCustomCreate;
/// used to determine the exact class type of a TSynPersistent
// - could be used to create instances using its virtual constructor
TSynPersistentClass = class of TSynPersistent;
/// used to store one list of hashed RawUTF8 in TRawUTF8Interning pool
// - Delphi "object" is buggy on stack -> also defined as record with methods
{$ifdef USERECORDWITHMETHODS}TRawUTF8InterningSlot = record
{$else}TRawUTF8InterningSlot = object{$endif}
public
/// actual RawUTF8 storage
Value: TRawUTF8DynArray;
/// hashed access to the Value[] list
Values: TDynArrayHashed;
/// associated mutex for thread-safe process
Safe: TSynLocker;
/// initialize the RawUTF8 slot (and its Safe mutex)
procedure Init;
/// finalize the RawUTF8 slot - mainly its associated Safe mutex
procedure Done;
/// returns the interned RawUTF8 value
procedure Unique(var aResult: RawUTF8; const aText: RawUTF8; aTextHash: cardinal);
/// ensure the supplied RawUTF8 value is interned
procedure UniqueText(var aText: RawUTF8; aTextHash: cardinal);
/// delete all stored RawUTF8 values
procedure Clear;
/// reclaim any unique RawUTF8 values
function Clean(aMaxRefCount: integer): integer;
/// how many items are currently stored in Value[]
function Count: integer;
end;
/// allow to store only one copy of distinct RawUTF8 values
// - thanks to the Copy-On-Write feature of string variables, this may
// reduce a lot the memory overhead of duplicated text content
// - this class is thread-safe and optimized for performance
TRawUTF8Interning = class(TSynPersistent)
protected
fPool: array of TRawUTF8InterningSlot;
fPoolLast: integer;
public
/// initialize the storage and its internal hash pools
// - aHashTables is the pool size, and should be a power of two <= 512
constructor Create(aHashTables: integer=4); reintroduce;
/// finalize the storage
destructor Destroy; override;
/// return a RawUTF8 variable stored within this class
// - if aText occurs for the first time, add it to the internal string pool
// - if aText does exist in the internal string pool, return the shared
// instance (with its reference counter increased), to reduce memory usage
function Unique(const aText: RawUTF8): RawUTF8; overload;
/// return a RawUTF8 variable stored within this class from a text buffer
// - if aText occurs for the first time, add it to the internal string pool
// - if aText does exist in the internal string pool, return the shared
// instance (with its reference counter increased), to reduce memory usage
function Unique(aText: PUTF8Char; aTextLen: PtrInt): RawUTF8; overload;
/// return a RawUTF8 variable stored within this class
// - if aText occurs for the first time, add it to the internal string pool
// - if aText does exist in the internal string pool, return the shared
// instance (with its reference counter increased), to reduce memory usage
procedure Unique(var aResult: RawUTF8; const aText: RawUTF8); overload;
/// return a RawUTF8 variable stored within this class from a text buffer
// - if aText occurs for the first time, add it to the internal string pool
// - if aText does exist in the internal string pool, return the shared
// instance (with its reference counter increased), to reduce memory usage
procedure Unique(var aResult: RawUTF8; aText: PUTF8Char; aTextLen: PtrInt); overload;
{$ifdef HASINLINE}inline;{$endif}
/// ensure a RawUTF8 variable is stored within this class
// - if aText occurs for the first time, add it to the internal string pool
// - if aText does exist in the internal string pool, set the shared
// instance (with its reference counter increased), to reduce memory usage
procedure UniqueText(var aText: RawUTF8);
{$ifndef NOVARIANTS}
/// return a variant containing a RawUTF8 stored within this class
// - similar to RawUTF8ToVariant(), but with string interning
procedure UniqueVariant(var aResult: variant; const aText: RawUTF8); overload;
{$ifdef HASINLINE}inline;{$endif}
/// return a variant containing a RawUTF8 stored within this class
// - similar to RawUTF8ToVariant(StringToUTF8()), but with string interning
// - this method expects the text to be supplied as a VCL string, which will
// be converted into a variant containing a RawUTF8 varString instance
procedure UniqueVariantString(var aResult: variant; const aText: string);
/// return a variant, may be containing a RawUTF8 stored within this class
// - similar to TextToVariant(), but with string interning
// - first try with GetNumericVariantFromJSON(), then fallback to
// RawUTF8ToVariant() with string variable interning
procedure UniqueVariant(var aResult: variant; aText: PUTF8Char; aTextLen: PtrInt;
aAllowVarDouble: boolean=false); overload;
/// ensure a variant contains only RawUTF8 stored within this class
// - supplied variant should be a varString containing a RawUTF8 value
procedure UniqueVariant(var aResult: variant); overload; {$ifdef HASINLINE}inline;{$endif}
{$endif NOVARIANTS}
/// delete any previous storage pool
procedure Clear;
/// reclaim any unique RawUTF8 values
// - i.e. run a garbage collection process of all values with RefCount=1
// by default, i.e. all string which are not used any more; you may set
// aMaxRefCount to a higher value, depending on your expecations, i.e. 2 to
// delete all string which are referenced only once outside of the pool
// - returns the number of unique RawUTF8 cleaned from the internal pool
// - to be executed on a regular basis - but not too often, since the
// process can be time consumming, and void the benefit of interning
function Clean(aMaxRefCount: integer=1): integer;
/// how many items are currently stored in this instance
function Count: integer;
end;
/// store one Name/Value pair, as used by TSynNameValue class
TSynNameValueItem = record
/// the name of the Name/Value pair
// - this property is hashed by TSynNameValue for fast retrieval
Name: RawUTF8;
/// the value of the Name/Value pair
Value: RawUTF8;
/// any associated Pointer or numerical value
Tag: PtrInt;
end;
/// Name/Value pairs storage, as used by TSynNameValue class
TSynNameValueItemDynArray = array of TSynNameValueItem;
/// event handler used to convert on the fly some UTF-8 text content
TOnSynNameValueConvertRawUTF8 = function(const text: RawUTF8): RawUTF8 of object;
/// callback event used by TSynNameValue
TOnSynNameValueNotify = procedure(const Item: TSynNameValueItem; Index: PtrInt) of object;
/// pseudo-class used to store Name/Value RawUTF8 pairs
// - use internaly a TDynArrayHashed instance for fast retrieval
// - is therefore faster than TRawUTF8List
// - is defined as an object, not as a class: you can use this in any
// class, without the need to destroy the content
// - Delphi "object" is buggy on stack -> also defined as record with methods
{$ifdef USERECORDWITHMETHODS}TSynNameValue = record
{$else}TSynNameValue = object {$endif}
private
fOnAdd: TOnSynNameValueNotify;
function GetBlobData: RawByteString;
procedure SetBlobData(const aValue: RawByteString);
function GetStr(const aName: RawUTF8): RawUTF8; {$ifdef HASINLINE}inline;{$endif}
function GetInt(const aName: RawUTF8): Int64; {$ifdef HASINLINE}inline;{$endif}
function GetBool(const aName: RawUTF8): Boolean; {$ifdef HASINLINE}inline;{$endif}
public
/// the internal Name/Value storage
List: TSynNameValueItemDynArray;
/// the number of Name/Value pairs
Count: integer;
/// low-level access to the internal storage hasher
DynArray: TDynArrayHashed;
/// initialize the storage
// - will also reset the internal List[] and the internal hash array
procedure Init(aCaseSensitive: boolean);
/// add an element to the array
// - if aName already exists, its associated Value will be updated
procedure Add(const aName, aValue: RawUTF8; aTag: PtrInt=0);
/// reset content, then add all name=value pairs from a supplied .ini file
// section content
// - will first call Init(false) to initialize the internal array
// - Section can be retrieved e.g. via FindSectionFirstLine()
procedure InitFromIniSection(Section: PUTF8Char; OnTheFlyConvert: TOnSynNameValueConvertRawUTF8=nil;
OnAdd: TOnSynNameValueNotify=nil);
/// reset content, then add all name=value; CSV pairs
// - will first call Init(false) to initialize the internal array
// - if ItemSep=#10, then any kind of line feed (CRLF or LF) will be handled
procedure InitFromCSV(CSV: PUTF8Char; NameValueSep: AnsiChar='=';
ItemSep: AnsiChar=#10);
/// reset content, then add all fields from an JSON object
// - will first call Init() to initialize the internal array
// - then parse the incoming JSON object, storing all its field values
// as RawUTF8, and returning TRUE if the supplied content is correct
// - warning: the supplied JSON buffer will be decoded and modified in-place
function InitFromJSON(JSON: PUTF8Char; aCaseSensitive: boolean=false): boolean;
/// reset content, then add all name, value pairs
// - will first call Init(false) to initialize the internal array
procedure InitFromNamesValues(const Names, Values: array of RawUTF8);
/// search for a Name, return the index in List
// - using fast O(1) hash algoritm
function Find(const aName: RawUTF8): integer;
/// search for the first chars of a Name, return the index in List
// - using O(n) calls of IdemPChar() function
// - here aUpperName should be already uppercase, as expected by IdemPChar()
function FindStart(const aUpperName: RawUTF8): integer;
/// search for a Value, return the index in List
// - using O(n) brute force algoritm with case-sensitive aValue search
function FindByValue(const aValue: RawUTF8): integer;
/// search for a Name, and delete its entry in the List if it exists
function Delete(const aName: RawUTF8): boolean;
/// search for a Value, and delete its entry in the List if it exists
// - returns the number of deleted entries
// - you may search for more than one match, by setting a >1 Limit value
function DeleteByValue(const aValue: RawUTF8; Limit: integer=1): integer;
/// search for a Name, return the associated Value as a UTF-8 string
function Value(const aName: RawUTF8; const aDefaultValue: RawUTF8=''): RawUTF8;
/// search for a Name, return the associated Value as integer
function ValueInt(const aName: RawUTF8; const aDefaultValue: Int64=0): Int64;
/// search for a Name, return the associated Value as boolean
// - returns true only if the value is exactly '1'
function ValueBool(const aName: RawUTF8): Boolean;
/// search for a Name, return the associated Value as an enumerate
// - returns true and set aEnum if aName was found, and associated value
// matched an aEnumTypeInfo item
// - returns false if no match was found
function ValueEnum(const aName: RawUTF8; aEnumTypeInfo: pointer; out aEnum;
aEnumDefault: byte=0): boolean; overload;
/// returns all values, as CSV or INI content
function AsCSV(const KeySeparator: RawUTF8='=';
const ValueSeparator: RawUTF8=#13#10; const IgnoreKey: RawUTF8=''): RawUTF8;
/// returns all values as a JSON object of string fields
function AsJSON: RawUTF8;
/// fill the supplied two arrays of RawUTF8 with the stored values
procedure AsNameValues(out Names,Values: TRawUTF8DynArray);
{$ifndef NOVARIANTS}
/// search for a Name, return the associated Value as variant
// - returns null if the name was not found
function ValueVariantOrNull(const aName: RawUTF8): variant;
/// compute a TDocVariant document from the stored values
// - output variant will be reset and filled as a TDocVariant instance,
// ready to be serialized as a JSON object
// - if there is no value stored (i.e. Count=0), set null
procedure AsDocVariant(out DocVariant: variant;
ExtendedJson: boolean=false; ValueAsString: boolean=true;
AllowVarDouble: boolean=false); overload;
/// compute a TDocVariant document from the stored values
function AsDocVariant(ExtendedJson: boolean=false; ValueAsString: boolean=true): variant; overload; {$ifdef HASINLINE}inline;{$endif}
/// merge the stored values into a TDocVariant document
// - existing properties would be updated, then new values will be added to
// the supplied TDocVariant instance, ready to be serialized as a JSON object
// - if ValueAsString is TRUE, values would be stored as string
// - if ValueAsString is FALSE, numerical values would be identified by
// IsString() and stored as such in the resulting TDocVariant
// - if you let ChangedProps point to a TDocVariantData, it would contain
// an object with the stored values, just like AsDocVariant
// - returns the number of updated values in the TDocVariant, 0 if
// no value was changed
function MergeDocVariant(var DocVariant: variant;
ValueAsString: boolean; ChangedProps: PVariant=nil;
ExtendedJson: boolean=false; AllowVarDouble: boolean=false): integer;
{$endif}
/// returns true if the Init() method has been called
function Initialized: boolean;
/// can be used to set all data from one BLOB memory buffer
procedure SetBlobDataPtr(aValue: pointer);
/// can be used to set or retrieve all stored data as one BLOB content
property BlobData: RawByteString read GetBlobData write SetBlobData;
/// event triggerred after an item has just been added to the list
property OnAfterAdd: TOnSynNameValueNotify read fOnAdd write fOnAdd;
/// search for a Name, return the associated Value as a UTF-8 string
// - returns '' if aName is not found in the stored keys
property Str[const aName: RawUTF8]: RawUTF8 read GetStr; default;
/// search for a Name, return the associated Value as integer
// - returns 0 if aName is not found, or not a valid Int64 in the stored keys
property Int[const aName: RawUTF8]: Int64 read GetInt;
/// search for a Name, return the associated Value as boolean
// - returns true if aName stores '1' as associated value
property Bool[const aName: RawUTF8]: Boolean read GetBool;
end;
/// a reference pointer to a Name/Value RawUTF8 pairs storage
PSynNameValue = ^TSynNameValue;
/// allocate and initialize a TSynLocker instance
// - caller should call result^.DoneAndFreemem when not used any more
function NewSynLocker: PSynLocker;
{$ifdef HASINLINE}inline;{$endif}
/// wrapper to add an item to a array of pointer dynamic array storage
function PtrArrayAdd(var aPtrArray; aItem: pointer): integer;
{$ifdef HASINLINE}inline;{$endif}
/// wrapper to add once an item to a array of pointer dynamic array storage
function PtrArrayAddOnce(var aPtrArray; aItem: pointer): integer;
/// wrapper to delete an item from a array of pointer dynamic array storage
function PtrArrayDelete(var aPtrArray; aItem: pointer; aCount: PInteger=nil): integer; overload;
/// wrapper to delete an item from a array of pointer dynamic array storage
procedure PtrArrayDelete(var aPtrArray; aIndex: integer; aCount: PInteger=nil); overload;
/// wrapper to find an item to a array of pointer dynamic array storage
function PtrArrayFind(var aPtrArray; aItem: pointer): integer;
{$ifdef HASINLINE}inline;{$endif}
/// wrapper to add an item to a T*ObjArray dynamic array storage
// - as expected by TJSONSerializer.RegisterObjArrayForJSON()
// - could be used as such (note the T*ObjArray type naming convention):
// ! TUserObjArray = array of TUser;
// ! ...
// ! var arr: TUserObjArray;
// ! user: TUser;
// ! ..
// ! try
// ! user := TUser.Create;
// ! user.Name := 'Name';
// ! index := ObjArrayAdd(arr,user);
// ! ...
// ! finally
// ! ObjArrayClear(arr); // release all items
// ! end;
// - return the index of the item in the dynamic array
function ObjArrayAdd(var aObjArray; aItem: TObject): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
/// wrapper to add items to a T*ObjArray dynamic array storage
// - aSourceObjArray[] items are just copied to aDestObjArray, which remains untouched
// - return the new number of the items in aDestObjArray
function ObjArrayAddFrom(var aDestObjArray; const aSourceObjArray): PtrInt;
/// wrapper to add and move items to a T*ObjArray dynamic array storage
// - aSourceObjArray[] items will be owned by aDestObjArray[], therefore
// aSourceObjArray is set to nil
// - return the new number of the items in aDestObjArray
function ObjArrayAppend(var aDestObjArray, aSourceObjArray): PtrInt;
/// wrapper to add an item to a T*ObjArray dynamic array storage
// - this overloaded function will use a separated variable to store the items
// count, so will be slightly faster: but you should call SetLength() when done,
// to have an array as expected by TJSONSerializer.RegisterObjArrayForJSON()
// - return the index of the item in the dynamic array
function ObjArrayAddCount(var aObjArray; aItem: TObject; var aObjArrayCount: integer): PtrInt;
/// wrapper to add once an item to a T*ObjArray dynamic array storage
// - as expected by TJSONSerializer.RegisterObjArrayForJSON()
// - if the object is already in the array (searching by address/reference,
// not by content), return its current index in the dynamic array
// - if the object does not appear in the array, add it at the end
procedure ObjArrayAddOnce(var aObjArray; aItem: TObject);
// - aSourceObjArray[] items are just copied to aDestObjArray, which remains untouched
// - will first check if aSourceObjArray[] items are not already in aDestObjArray
// - return the new number of the items in aDestObjArray
function ObjArrayAddOnceFrom(var aDestObjArray; const aSourceObjArray): PtrInt;
/// wrapper to set the length of a T*ObjArray dynamic array storage
// - could be used as an alternative to SetLength() when you do not
// know the exact T*ObjArray type
procedure ObjArraySetLength(var aObjArray; aLength: integer);
{$ifdef HASINLINE}inline;{$endif}
/// wrapper to search an item in a T*ObjArray dynamic array storage
// - as expected by TJSONSerializer.RegisterObjArrayForJSON()
// - search is performed by address/reference, not by content
// - returns -1 if the item is not found in the dynamic array
function ObjArrayFind(const aObjArray; aItem: TObject): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// wrapper to search an item in a T*ObjArray dynamic array storage
// - as expected by TJSONSerializer.RegisterObjArrayForJSON()
// - search is performed by address/reference, not by content
// - returns -1 if the item is not found in the dynamic array
function ObjArrayFind(const aObjArray; aCount: integer; aItem: TObject): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// wrapper to count all not nil items in a T*ObjArray dynamic array storage
// - as expected by TJSONSerializer.RegisterObjArrayForJSON()
function ObjArrayCount(const aObjArray): integer;
/// wrapper to delete an item in a T*ObjArray dynamic array storage
// - as expected by TJSONSerializer.RegisterObjArrayForJSON()
// - do nothing if the index is out of range in the dynamic array
procedure ObjArrayDelete(var aObjArray; aItemIndex: PtrInt;
aContinueOnException: boolean=false; aCount: PInteger=nil); overload;
/// wrapper to delete an item in a T*ObjArray dynamic array storage
// - as expected by TJSONSerializer.RegisterObjArrayForJSON()
// - search is performed by address/reference, not by content
// - do nothing if the item is not found in the dynamic array
function ObjArrayDelete(var aObjArray; aItem: TObject): PtrInt; overload;
/// wrapper to delete an item in a T*ObjArray dynamic array storage
// - as expected by TJSONSerializer.RegisterObjArrayForJSON()
// - search is performed by address/reference, not by content
// - do nothing if the item is not found in the dynamic array
function ObjArrayDelete(var aObjArray; aCount: integer; aItem: TObject): PtrInt; overload;
/// wrapper to sort the items stored in a T*ObjArray dynamic array
// - as expected by TJSONSerializer.RegisterObjArrayForJSON()
procedure ObjArraySort(var aObjArray; Compare: TDynArraySortCompare);
/// wrapper to release all items stored in a T*ObjArray dynamic array
// - as expected by TJSONSerializer.RegisterObjArrayForJSON()
// - you should always use ObjArrayClear() before the array storage is released,
// e.g. in the owner class destructor
// - will also set the dynamic array length to 0, so could be used to re-use
// an existing T*ObjArray
procedure ObjArrayClear(var aObjArray); overload;
/// wrapper to release all items stored in a T*ObjArray dynamic array
// - this overloaded function will use the supplied array length as parameter
// - you should always use ObjArrayClear() before the array storage is released,
// e.g. in the owner class destructor
// - will also set the dynamic array length to 0, so could be used to re-use
// an existing T*ObjArray
procedure ObjArrayClear(var aObjArray; aCount: integer); overload;
/// wrapper to release all items stored in a T*ObjArray dynamic array
// - as expected by TJSONSerializer.RegisterObjArrayForJSON()
// - you should always use ObjArrayClear() before the array storage is released,
// e.g. in the owner class destructor
// - will also set the dynamic array length to 0, so could be used to re-use
// an existing T*ObjArray
procedure ObjArrayClear(var aObjArray; aContinueOnException: boolean;
aCount: PInteger=nil); overload;
/// wrapper to release all items stored in an array of T*ObjArray dynamic array
// - e.g. aObjArray may be defined as "array of array of TSynFilter"
procedure ObjArrayObjArrayClear(var aObjArray);
/// wrapper to release all items stored in several T*ObjArray dynamic arrays
// - as expected by TJSONSerializer.RegisterObjArrayForJSON()
procedure ObjArraysClear(const aObjArray: array of pointer);
/// low-level function calling FreeAndNil(o^) successively n times
procedure RawObjectsClear(o: PObject; n: integer);
{$ifndef DELPHI5OROLDER}
/// wrapper to add an item to a T*InterfaceArray dynamic array storage
function InterfaceArrayAdd(var aInterfaceArray; const aItem: IUnknown): PtrInt;
/// wrapper to add once an item to a T*InterfaceArray dynamic array storage
procedure InterfaceArrayAddOnce(var aInterfaceArray; const aItem: IUnknown);
/// wrapper to search an item in a T*InterfaceArray dynamic array storage
// - search is performed by address/reference, not by content
// - return -1 if the item is not found in the dynamic array, or the index of
// the matching entry otherwise
function InterfaceArrayFind(const aInterfaceArray; const aItem: IUnknown): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
/// wrapper to delete an item in a T*InterfaceArray dynamic array storage
// - search is performed by address/reference, not by content
// - do nothing if the item is not found in the dynamic array
function InterfaceArrayDelete(var aInterfaceArray; const aItem: IUnknown): PtrInt; overload;
/// wrapper to delete an item in a T*InterfaceArray dynamic array storage
// - do nothing if the item is not found in the dynamic array
procedure InterfaceArrayDelete(var aInterfaceArray; aItemIndex: PtrInt); overload;
{$endif DELPHI5OROLDER}
/// helper to retrieve the text of an enumerate item
// - see also RTTI related classes of mORMot.pas unit, e.g. TEnumType
function GetEnumName(aTypeInfo: pointer; aIndex: integer): PShortString;
/// helper to retrieve all texts of an enumerate
// - may be used as cache for overloaded ToText() content
procedure GetEnumNames(aTypeInfo: pointer; aDest: PPShortString);
/// helper to retrieve all trimmed texts of an enumerate
// - may be used as cache to retrieve UTF-8 text without lowercase 'a'..'z' chars
procedure GetEnumTrimmedNames(aTypeInfo: pointer; aDest: PRawUTF8); overload;
/// helper to retrieve all trimmed texts of an enumerate as UTF-8 strings
function GetEnumTrimmedNames(aTypeInfo: pointer): TRawUTF8DynArray; overload;
/// helper to retrieve all (translated) caption texts of an enumerate
// - may be used as cache for overloaded ToCaption() content
procedure GetEnumCaptions(aTypeInfo: pointer; aDest: PString);
/// UnCamelCase and translate the enumeration item
function GetCaptionFromEnum(aTypeInfo: pointer; aIndex: integer): string;
/// low-level helper to retrieve a (translated) caption from a PShortString
// - as used e.g. by GetEnumCaptions or GetCaptionFromEnum
procedure GetCaptionFromTrimmed(PS: PShortString; var result: string);
/// helper to retrieve the index of an enumerate item from its text
// - returns -1 if aValue was not found
// - will search for the exact text and also trim the lowercase 'a'..'z' chars on
// left side of the text if no exact match is found and AlsoTrimLowerCase is TRUE
// - see also RTTI related classes of mORMot.pas unit, e.g. TEnumType
function GetEnumNameValue(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt;
AlsoTrimLowerCase: boolean=false): Integer; overload;
/// retrieve the index of an enumerate item from its left-trimmed text
// - text comparison is case-insensitive for A-Z characters
// - will trim the lowercase 'a'..'z' chars on left side of the supplied aValue text
// - returns -1 if aValue was not found
function GetEnumNameValueTrimmed(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt): integer;
/// retrieve the index of an enumerate item from its left-trimmed text
// - text comparison is case-sensitive for A-Z characters
// - will trim the lowercase 'a'..'z' chars on left side of the supplied aValue text
// - returns -1 if aValue was not found
function GetEnumNameValueTrimmedExact(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt): integer;
/// helper to retrieve the index of an enumerate item from its text
function GetEnumNameValue(aTypeInfo: pointer; const aValue: RawUTF8;
AlsoTrimLowerCase: boolean=false): Integer; overload;
/// helper to retrieve the bit mapped integer value of a set from its JSON text
// - if supplied P^ is a JSON integer number, will read it directly
// - if P^ maps some ["item1","item2"] content, would fill all matching bits
// - if P^ contains ['*'], would fill all bits
// - returns P=nil if reached prematurly the end of content, or returns
// the value separator (e.g. , or }) in EndOfObject (like GetJsonField)
function GetSetNameValue(aTypeInfo: pointer; var P: PUTF8Char;
out EndOfObject: AnsiChar): cardinal;
/// helper to retrieve the CSV text of all enumerate items defined in a set
// - you'd better use RTTI related classes of mORMot.pas unit, e.g. TEnumType
function GetSetName(aTypeInfo: pointer; const value): RawUTF8;
/// helper to retrieve the CSV text of all enumerate items defined in a set
// - you'd better use RTTI related classes of mORMot.pas unit, e.g. TEnumType
procedure GetSetNameShort(aTypeInfo: pointer; const value; out result: ShortString;
trimlowercase: boolean=false);
/// low-level helper to retrive the base enumeration RTTI of a given set
function GetSetBaseEnum(aTypeInfo: pointer): pointer;
/// fast append some UTF-8 text into a shortstring, with an ending ','
procedure AppendShortComma(text: PAnsiChar; len: PtrInt; var result: shortstring;
trimlowercase: boolean);
/// fast search of an exact case-insensitive match of a RTTI's PShortString array
function FindShortStringListExact(List: PShortString; MaxValue: integer;
aValue: PUTF8Char; aValueLen: PtrInt): integer;
/// fast case-insensitive search of a left-trimmed lowercase match
// of a RTTI's PShortString array
function FindShortStringListTrimLowerCase(List: PShortString; MaxValue: integer;
aValue: PUTF8Char; aValueLen: PtrInt): integer;
/// fast case-sensitive search of a left-trimmed lowercase match
// of a RTTI's PShortString array
function FindShortStringListTrimLowerCaseExact(List: PShortString; MaxValue: integer;
aValue: PUTF8Char; aValueLen: PtrInt): integer;
/// retrieve the type name from its low-level RTTI
function TypeInfoToName(aTypeInfo: pointer): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// retrieve the type name from its low-level RTTI
procedure TypeInfoToName(aTypeInfo: pointer; var result: RawUTF8;
const default: RawUTF8=''); overload;
/// retrieve the unit name and type name from its low-level RTTI
procedure TypeInfoToQualifiedName(aTypeInfo: pointer; var result: RawUTF8;
const default: RawUTF8='');
/// compute a crc32c-based hash of the RTTI for a managed given type
// - can be used to ensure that the RecordSave/TDynArray.SaveTo binary layout
// is compatible accross executables, even between FPC and Delphi
// - will ignore the type names, but will check the RTTI type kind and any
// nested fields (for records or arrays) - for a record/object type, will use
// TTextWriter.RegisterCustomJSONSerializerFromText definition, if available
function TypeInfoToHash(aTypeInfo: pointer): cardinal;
/// retrieve the record size from its low-level RTTI
function RecordTypeInfoSize(aRecordTypeInfo: pointer): integer;
/// retrieve the item type information of a dynamic array low-level RTTI
function DynArrayTypeInfoToRecordInfo(aDynArrayTypeInfo: pointer;
aDataSize: PInteger=nil): pointer;
/// sort any dynamic array, via an external array of indexes
// - this function will use the supplied TSynTempBuffer for index storage,
// so use PIntegerArray(Indexes.buf) to access the values
// - caller should always make Indexes.Done once done
procedure DynArraySortIndexed(Values: pointer; ElemSize, Count: Integer;
out Indexes: TSynTempBuffer; Compare: TDynArraySortCompare);
/// compare two TGUID values
// - this version is faster than the one supplied by SysUtils
function IsEqualGUID(const guid1, guid2: TGUID): Boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// compare two TGUID values
// - this version is faster than the one supplied by SysUtils
function IsEqualGUID(guid1, guid2: PGUID): Boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// returns the index of a matching TGUID in an array
// - returns -1 if no item matched
function IsEqualGUIDArray(const guid: TGUID; const guids: array of TGUID): integer;
/// check if a TGUID value contains only 0 bytes
// - this version is faster than the one supplied by SysUtils
function IsNullGUID({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): Boolean;
{$ifdef HASINLINE}inline;{$endif}
/// append one TGUID item to a TGUID dynamic array
// - returning the newly inserted index in guids[], or an existing index in
// guids[] if NoDuplicates is TRUE and TGUID already exists
function AddGUID(var guids: TGUIDDynArray; const guid: TGUID;
NoDuplicates: boolean=false): integer;
/// append a TGUID binary content as text
// - will store e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' (without any {})
// - this will be the format used for JSON encoding, e.g.
// $ { "UID": "C9A646D3-9C61-4CB7-BFCD-EE2522C8F633" }
function GUIDToText(P: PUTF8Char; guid: PByteArray): PUTF8Char;
/// convert a TGUID into UTF-8 encoded text
// - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {})
// - if you do not need the embracing { }, use ToUTF8() overloaded function
function GUIDToRawUTF8({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): RawUTF8;
/// convert a TGUID into text
// - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {})
// - this version is faster than the one supplied by SysUtils
function GUIDToString({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): string;
type
/// low-level object implementing a 32-bit Pierre L'Ecuyer software generator
// - as used by Random32gsl, and Random32 if no RDRAND hardware is available
// - is not thread-safe by itself, but cross-compiler and cross-platform, still
// very fast with a much better distribution than Delphi system's Random() function
// - Random32gsl/Random32 will use a threadvar to have thread safety
TLecuyer = object
public
rs1, rs2, rs3, seedcount: cardinal;
/// force an immediate seed of the generator from current system state
// - should be called before any call to the Next method
procedure Seed(entropy: PByteArray; entropylen: PtrInt);
/// compute the next 32-bit generated value
// - will automatically reseed after around 65,000 generated values
function Next: cardinal; overload;
/// compute the next 32-bit generated value, in range [0..max-1]
// - will automatically reseed after around 65,000 generated values
function Next(max: cardinal): cardinal; overload;
end;
/// fast compute of some 32-bit random value
// - will use (slow but) hardware-derivated RDRAND Intel x86/x64 opcode if
// available, or fast gsl_rng_taus2 generator by Pierre L'Ecuyer (which period
// is 2^88, i.e. about 10^26) if the CPU doesn't support it
// - will detect known AMD CPUs RDRAND bugs, and fallback to gsl_rng_taus2
// - consider Random32gsl to avoid slow RDRAND call (up to 1500 cycles needed!)
// - use rather TAESPRNG.Main.FillRandom() for cryptographic-level randomness
// - thread-safe function: each thread will maintain its own TLecuyer table
function Random32: cardinal; overload;
/// fast compute of some 32-bit random value, with a maximum (excluded) upper value
// - i.e. returns a value in range [0..max-1]
// - calls internally the overloaded Random32 function
function Random32(max: cardinal): cardinal; overload;
/// fast compute of some 32-bit random value, using the gsl_rng_taus2 generator
// - Random32 may call RDRAND opcode on Intel CPUs, wherease this function will use
// well documented, much faster, and proven Pierre L'Ecuyer software generator
// - may be used if you don't want/trust RDRAND, if you expect a well defined
// cross-platform generator, or have higher performance expectations
// - use rather TAESPRNG.Main.FillRandom() for cryptographic-level randomness
// - thread-safe function: each thread will maintain its own TLecuyer table
function Random32gsl: cardinal; overload;
/// fast compute of bounded 32-bit random value, using the gsl_rng_taus2 generator
// - calls internally the overloaded Random32gsl function
function Random32gsl(max: cardinal): cardinal; overload;
/// seed the gsl_rng_taus2 Random32/Random32gsl generator
// - this seeding won't affect RDRAND Intel x86/x64 opcode generation
// - by default, gsl_rng_taus2 generator is re-seeded every 256KB, much more
// often than the Pierre L'Ecuyer's algorithm period of 2^88
// - you can specify some additional entropy buffer; note that calling this
// function with the same entropy again WON'T seed the generator with the same
// sequence (as with RTL's RandomSeed function), but initiate a new one
// - thread-specific function: each thread will maintain its own seed table
procedure Random32Seed(entropy: pointer=nil; entropylen: PtrInt=0);
/// fill some memory buffer with random values
// - the destination buffer is expected to be allocated as 32-bit items
// - use internally crc32c() with some rough entropy source, and Random32
// gsl_rng_taus2 generator or hardware RDRAND Intel x86/x64 opcode if available
// (and ForceGsl is kept to its default false)
// - consider using instead the cryptographic secure TAESPRNG.Main.FillRandom()
// method from the SynCrypto unit, or set ForceGsl=true - in particular, RDRAND
// is reported as very slow: see https://en.wikipedia.org/wiki/RdRand#Performance
procedure FillRandom(Dest: PCardinalArray; CardinalCount: integer; ForceGsl: boolean=false);
/// compute a random GUID value
procedure RandomGUID(out result: TGUID); overload;
{$ifdef HASINLINE}inline;{$endif}
/// compute a random GUID value
function RandomGUID: TGUID; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fill a GUID with 0
procedure FillZero(var result: TGUID); overload; {$ifdef HASINLINE}inline;{$endif}
type
/// stack-allocated ASCII string, used by GUIDToShort() function
TGUIDShortString = string[38];
const
/// a TGUID containing '{00000000-0000-0000-0000-00000000000}'
GUID_NULL: TGUID = ();
/// convert a TGUID into text
// - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {})
// - using a shortstring will allow fast allocation on the stack, so is
// preferred e.g. when providing a GUID to a ESynException.CreateUTF8()
function GUIDToShort({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF}
guid: TGUID): TGUIDShortString; overload; {$ifdef HASINLINE}inline;{$endif}
/// convert a TGUID into text
// - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {})
// - using a shortstring will allow fast allocation on the stack, so is
// preferred e.g. when providing a GUID to a ESynException.CreateUTF8()
procedure GUIDToShort({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF}
guid: TGUID; out dest: TGUIDShortString); overload;
/// convert some text into its TGUID binary value
// - expect e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' (without any {})
// - return nil if the supplied text buffer is not a valid TGUID
// - this will be the format used for JSON encoding, e.g.
// $ { "UID": "C9A646D3-9C61-4CB7-BFCD-EE2522C8F633" }
function TextToGUID(P: PUTF8Char; guid: PByteArray): PUTF8Char;
/// convert some text into a TGUID
// - expect e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {})
// - return {00000000-0000-0000-0000-000000000000} if the supplied text buffer
// is not a valid TGUID
function StringToGUID(const text: string): TGUID;
/// convert some UTF-8 encoded text into a TGUID
// - expect e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {})
// - return {00000000-0000-0000-0000-000000000000} if the supplied text buffer
// is not a valid TGUID
function RawUTF8ToGUID(const text: RawByteString): TGUID;
/// check equality of two records by content
// - will handle packed records, with binaries (byte, word, integer...) and
// string types properties
// - will use binary-level comparison: it could fail to match two floating-point
// values because of rounding issues (Currency won't have this problem)
function RecordEquals(const RecA, RecB; TypeInfo: pointer;
PRecSize: PInteger=nil): boolean;
/// save a record content into a RawByteString
// - will handle packed records, with binaries (byte, word, integer...) and
// string types properties (but not with internal raw pointers, of course)
// - will use a proprietary binary format, with some variable-length encoding
// of the string length - note that if you change the type definition, any
// previously-serialized content will fail, maybe triggering unexpected GPF: you
// may use TypeInfoToHash() if you share this binary data accross executables
// - warning: will encode generic string fields as AnsiString (one byte per char)
// prior to Delphi 2009, and as UnicodeString (two bytes per char) since Delphi
// 2009: if you want to use this function between UNICODE and NOT UNICODE
// versions of Delphi, you should use some explicit types like RawUTF8,
// WinAnsiString, SynUnicode or even RawUnicode/WideString
function RecordSave(const Rec; TypeInfo: pointer): RawByteString; overload;
/// save a record content into a TBytes dynamic array
// - could be used as an alternative to RawByteString's RecordSave()
function RecordSaveBytes(const Rec; TypeInfo: pointer): TBytes;
/// save a record content into a destination memory buffer
// - Dest must be at least RecordSaveLength() bytes long
// - will return the Rec size, in bytes, into Len reference variable
// - will handle packed records, with binaries (byte, word, integer...) and
// string types properties (but not with internal raw pointers, of course)
// - will use a proprietary binary format, with some variable-length encoding
// of the string length - note that if you change the type definition, any
// previously-serialized content will fail, maybe triggering unexpected GPF: you
// may use TypeInfoToHash() if you share this binary data accross executables
// - warning: will encode generic string fields as AnsiString (one byte per char)
// prior to Delphi 2009, and as UnicodeString (two bytes per char) since Delphi
// 2009: if you want to use this function between UNICODE and NOT UNICODE
// versions of Delphi, you should use some explicit types like RawUTF8,
// WinAnsiString, SynUnicode or even RawUnicode/WideString
function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: pointer;
out Len: integer): PAnsiChar; overload;
/// save a record content into a destination memory buffer
// - Dest must be at least RecordSaveLength() bytes long
// - will handle packed records, with binaries (byte, word, integer...) and
// string types properties (but not with internal raw pointers, of course)
// - will use a proprietary binary format, with some variable-length encoding
// of the string length - note that if you change the type definition, any
// previously-serialized content will fail, maybe triggering unexpected GPF: you
// may use TypeInfoToHash() if you share this binary data accross executables
// - warning: will encode generic string fields as AnsiString (one byte per char)
// prior to Delphi 2009, and as UnicodeString (two bytes per char) since Delphi
// 2009: if you want to use this function between UNICODE and NOT UNICODE
// versions of Delphi, you should use some explicit types like RawUTF8,
// WinAnsiString, SynUnicode or even RawUnicode/WideString
function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: pointer): PAnsiChar; overload;
{$ifdef HASINLINE}inline;{$endif}
/// save a record content into a destination memory buffer
// - caller should make Dest.Done once finished with Dest.buf/Dest.len buffer
procedure RecordSave(const Rec; var Dest: TSynTempBuffer; TypeInfo: pointer); overload;
/// save a record content into a Base-64 encoded UTF-8 text content
// - will use RecordSave() format, with a left-sided binary CRC32C
function RecordSaveBase64(const Rec; TypeInfo: pointer; UriCompatible: boolean=false): RawUTF8;
/// compute the number of bytes needed to save a record content
// using the RecordSave() function
// - will return 0 in case of an invalid (not handled) record type (e.g. if
// it contains an unknown variant)
// - optional Len parameter will contain the Rec memory buffer length, in bytes
function RecordSaveLength(const Rec; TypeInfo: pointer; Len: PInteger=nil): integer;
/// save record into its JSON serialization as saved by TTextWriter.AddRecordJSON
// - will use default Base64 encoding over RecordSave() binary - or custom true
// JSON format (as set by TTextWriter.RegisterCustomJSONSerializer or via
// enhanced RTTI), if available (following EnumSetsAsText optional parameter
// for nested enumerates and sets)
function RecordSaveJSON(const Rec; TypeInfo: pointer;
EnumSetsAsText: boolean=false): RawUTF8;
{$ifdef HASINLINE}inline;{$endif}
/// fill a record content from a memory buffer as saved by RecordSave()
// - return nil if the Source buffer is incorrect
// - in case of success, return the memory buffer pointer just after the
// read content, and set the Rec size, in bytes, into Len reference variable
// - will use a proprietary binary format, with some variable-length encoding
// of the string length - note that if you change the type definition, any
// previously-serialized content will fail, maybe triggering unexpected GPF: you
// may use TypeInfoToHash() if you share this binary data accross executables
// - you can optionally provide in SourceMax the first byte after the input
// memory buffer, which will be used to avoid any unexpected buffer overflow -
// would be mandatory when decoding the content from any external process
// (e.g. a maybe-forged client) - only with slightly performance penalty
function RecordLoad(var Rec; Source: PAnsiChar; TypeInfo: pointer;
Len: PInteger=nil; SourceMax: PAnsiChar=nil): PAnsiChar; overload;
/// fill a record content from a memory buffer as saved by RecordSave()
// - will use the Source length to detect and avoid any buffer overlow
// - returns false if the Source buffer was incorrect, true on success
function RecordLoad(var Res; const Source: RawByteString; TypeInfo: pointer): boolean; overload;
/// read a record content from a Base-64 encoded content
// - expects RecordSaveBase64() format, with a left-sided binary CRC
function RecordLoadBase64(Source: PAnsiChar; Len: PtrInt; var Rec; TypeInfo: pointer;
UriCompatible: boolean=false): boolean;
/// fill a record content from a JSON serialization as saved by
// TTextWriter.AddRecordJSON / RecordSaveJSON
// - will use default Base64 encoding over RecordSave() binary - or custom true
// JSON format (as set by TTextWriter.RegisterCustomJSONSerializer or via
// enhanced RTTI), if available
// - returns nil on error, or the end of buffer on success
// - warning: the JSON buffer will be modified in-place during process - use
// a temporary copy if you need to access it later or if the string comes from
// a constant (refcount=-1) - see e.g. the overloaded RecordLoadJSON()
function RecordLoadJSON(var Rec; JSON: PUTF8Char; TypeInfo: pointer;
EndOfObject: PUTF8Char=nil{$ifndef NOVARIANTS};
CustomVariantOptions: PDocVariantOptions=nil{$endif}): PUTF8Char; overload;
/// fill a record content from a JSON serialization as saved by
// TTextWriter.AddRecordJSON / RecordSaveJSON
// - this overloaded function will make a private copy before parsing it,
// so is safe with a read/only or shared string - but slightly slower
// - will use default Base64 encoding over RecordSave() binary - or custom true
// JSON format (as set by TTextWriter.RegisterCustomJSONSerializer or via
// enhanced RTTI), if available
function RecordLoadJSON(var Rec; const JSON: RawUTF8; TypeInfo: pointer{$ifndef NOVARIANTS};
CustomVariantOptions: PDocVariantOptions=nil{$endif}): boolean; overload;
/// copy a record content from source to Dest
// - this unit includes a fast optimized asm version for x86 on Delphi
procedure RecordCopy(var Dest; const Source; TypeInfo: pointer); {$ifdef FPC}inline;{$endif}
/// clear a record content
// - this unit includes a fast optimized asm version for x86 on Delphi
procedure RecordClear(var Dest; TypeInfo: pointer); {$ifdef FPC}inline;{$endif}
/// initialize a record content
// - calls RecordClear() and FillCharFast() with 0
// - do nothing if the TypeInfo is not from a record/object
procedure RecordZero(var Dest; TypeInfo: pointer);
/// low-level finalization of a dynamic array of variants
// - faster than RTL Finalize() or setting nil
procedure FastDynArrayClear(Value: PPointer; ElemTypeInfo: pointer);
/// low-level finalization of a dynamic array of RawUTF8
// - faster than RTL Finalize() or setting nil
procedure RawUTF8DynArrayClear(var Value: TRawUTF8DynArray);
{$ifdef HASINLINE}inline;{$endif}
{$ifndef DELPHI5OROLDER}
/// copy a dynamic array content from source to Dest
// - uses internally the TDynArray.CopyFrom() method and two temporary
// TDynArray wrappers
procedure DynArrayCopy(var Dest; const Source; SourceMaxElem: integer;
TypeInfo: pointer);
{$endif DELPHI5OROLDER}
/// fill a dynamic array content from a binary serialization as saved by
// DynArraySave() / TDynArray.Save()
// - Value shall be set to the target dynamic array field
// - just a function helper around TDynArray.Init + TDynArray.*
function DynArrayLoad(var Value; Source: PAnsiChar; TypeInfo: pointer): PAnsiChar;
/// serialize a dynamic array content as binary, ready to be loaded by
// DynArrayLoad() / TDynArray.Load()
// - Value shall be set to the source dynamic arry field
// - just a function helper around TDynArray.Init + TDynArray.SaveTo
function DynArraySave(var Value; TypeInfo: pointer): RawByteString;
/// fill a dynamic array content from a JSON serialization as saved by
// TTextWriter.AddDynArrayJSON
// - Value shall be set to the target dynamic array field
// - is just a wrapper around TDynArray.LoadFromJSON(), creating a temporary
// TDynArray wrapper on the stack
// - return a pointer at the end of the data read from JSON, nil in case
// of an invalid input buffer
// - to be used e.g. for custom record JSON unserialization, within a
// TDynArrayJSONCustomReader callback
// - warning: the JSON buffer will be modified in-place during process - use
// a temporary copy if you need to access it later or if the string comes from
// a constant (refcount=-1) - see e.g. the overloaded DynArrayLoadJSON()
function DynArrayLoadJSON(var Value; JSON: PUTF8Char; TypeInfo: pointer;
EndOfObject: PUTF8Char=nil): PUTF8Char; overload;
/// fill a dynamic array content from a JSON serialization as saved by
// TTextWriter.AddDynArrayJSON, which won't be modified
// - this overloaded function will make a private copy before parsing it,
// so is safe with a read/only or shared string - but slightly slower
function DynArrayLoadJSON(var Value; const JSON: RawUTF8; TypeInfo: pointer): boolean; overload;
/// serialize a dynamic array content as JSON
// - Value shall be set to the source dynamic array field
// - is just a wrapper around TTextWriter.AddDynArrayJSON(), creating
// a temporary TDynArray wrapper on the stack
// - to be used e.g. for custom record JSON serialization, within a
// TDynArrayJSONCustomWriter callback or RegisterCustomJSONSerializerFromText()
// (following EnumSetsAsText optional parameter for nested enumerates and sets)
function DynArraySaveJSON(const Value; TypeInfo: pointer;
EnumSetsAsText: boolean=false): RawUTF8;
{$ifdef HASINLINE}inline;{$endif}
{$ifndef DELPHI5OROLDER}
/// compare two dynamic arrays by calling TDynArray.Equals
function DynArrayEquals(TypeInfo: pointer; var Array1, Array2;
Array1Count: PInteger=nil; Array2Count: PInteger=nil): boolean;
{$endif DELPHI5OROLDER}
/// serialize a dynamic array content, supplied as raw binary buffer, as JSON
// - Value shall be set to the source dynamic array field
// - is just a wrapper around TTextWriter.AddDynArrayJSON(), creating
// a temporary TDynArray wrapper on the stack
// - to be used e.g. for custom record JSON serialization, within a
// TDynArrayJSONCustomWriter callback or RegisterCustomJSONSerializerFromText()
function DynArrayBlobSaveJSON(TypeInfo, BlobValue: pointer): RawUTF8;
/// compute a dynamic array element information
// - will raise an exception if the supplied RTTI is not a dynamic array
// - will return the element type name and set ElemTypeInfo otherwise
// - if there is no element type information, an approximative element type name
// will be returned (e.g. 'byte' for an array of 1 byte items), and ElemTypeInfo
// will be set to nil
// - this low-level function is used e.g. by mORMotWrappers unit
function DynArrayElementTypeName(TypeInfo: pointer; ElemTypeInfo: PPointer=nil;
ExactType: boolean=false): RawUTF8;
/// trim ending 'DynArray' or 's' chars from a dynamic array type name
// - used internally to guess the associated item type name
function DynArrayItemTypeLen(const aDynArrayTypeName: RawUTF8): PtrInt;
/// was dynamic array item after RegisterCustomJSONSerializerFromTextBinaryType()
// - calls DynArrayItemTypeLen() to guess the internal type name
function DynArrayItemTypeIsSimpleBinary(const aDynArrayTypeName: RawUTF8): boolean;
/// compare two "array of boolean" elements
function SortDynArrayBoolean(const A,B): integer;
/// compare two "array of shortint" elements
function SortDynArrayShortint(const A,B): integer;
/// compare two "array of byte" elements
function SortDynArrayByte(const A,B): integer;
/// compare two "array of smallint" elements
function SortDynArraySmallint(const A,B): integer;
/// compare two "array of word" elements
function SortDynArrayWord(const A,B): integer;
/// compare two "array of integer" elements
function SortDynArrayInteger(const A,B): integer;
/// compare two "array of cardinal" elements
function SortDynArrayCardinal(const A,B): integer;
/// compare two "array of Int64" or "array of Currency" elements
function SortDynArrayInt64(const A,B): integer;
/// compare two "array of QWord" elements
// - note that QWord(A)>QWord(B) is wrong on older versions of Delphi, so you
// should better use this function or CompareQWord() to properly compare two
// QWord values over CPUX86
function SortDynArrayQWord(const A,B): integer;
/// compare two "array of THash128" elements
function SortDynArray128(const A,B): integer;
/// compare two "array of THash256" elements
function SortDynArray256(const A,B): integer;
/// compare two "array of THash512" elements
function SortDynArray512(const A,B): integer;
/// compare two "array of TObject/pointer" elements
function SortDynArrayPointer(const A,B): integer;
/// compare two "array of single" elements
function SortDynArraySingle(const A,B): integer;
/// compare two "array of double" elements
function SortDynArrayDouble(const A,B): integer;
/// compare two "array of AnsiString" elements, with case sensitivity
function SortDynArrayAnsiString(const A,B): integer;
/// compare two "array of RawByteString" elements, with case sensitivity
// - can't use StrComp() or similar functions since RawByteString may contain #0
function SortDynArrayRawByteString(const A,B): integer;
/// compare two "array of AnsiString" elements, with no case sensitivity
function SortDynArrayAnsiStringI(const A,B): integer;
/// compare two "array of PUTF8Char/PAnsiChar" elements, with case sensitivity
function SortDynArrayPUTF8Char(const A,B): integer;
/// compare two "array of PUTF8Char/PAnsiChar" elements, with no case sensitivity
function SortDynArrayPUTF8CharI(const A,B): integer;
/// compare two "array of WideString/UnicodeString" elements, with case sensitivity
function SortDynArrayUnicodeString(const A,B): integer;
/// compare two "array of WideString/UnicodeString" elements, with no case sensitivity
function SortDynArrayUnicodeStringI(const A,B): integer;
/// compare two "array of generic string" elements, with case sensitivity
// - the expected string type is the generic VCL string
function SortDynArrayString(const A,B): integer;
/// compare two "array of generic string" elements, with no case sensitivity
// - the expected string type is the generic VCL string
function SortDynArrayStringI(const A,B): integer;
/// compare two "array of TFileName" elements, as file names
// - i.e. with no case sensitivity, and grouped by file extension
// - the expected string type is the generic RTL string, i.e. TFileName
// - calls internally GetFileNameWithoutExt() and AnsiCompareFileName()
function SortDynArrayFileName(const A,B): integer;
{$ifndef NOVARIANTS}
/// compare two "array of variant" elements, with case sensitivity
function SortDynArrayVariant(const A,B): integer;
/// compare two "array of variant" elements, with no case sensitivity
function SortDynArrayVariantI(const A,B): integer;
/// compare two "array of variant" elements, with or without case sensitivity
// - this low-level function is called by SortDynArrayVariant/VariantCompare
// - more optimized than the RTL function if A and B share the same type
function SortDynArrayVariantComp(const A,B: TVarData; caseInsensitive: boolean): integer;
{$endif NOVARIANTS}
{$ifdef CPU32DELPHI}
const
/// defined for inlining bitwise division in TDynArrayHasher.HashTableIndex
// - HashTableSize<=HASH_PO2 is expected to be a power of two (fast binary op);
// limit is set to 262,144 hash table slots (=1MB), for Capacity=131,072 items
// - above this limit, a set of increasing primes is used; using a prime as
// hashtable modulo enhances its distribution, especially for a weak hash function
// - 64-bit CPU and FPC can efficiently compute a prime reduction using Lemire
// algorithm, so no power of two is defined on those targets
HASH_PO2 = 1 shl 18;
{$endif CPU32DELPHI}
/// compute the 32-bit default hash of a file content
// - you can specify your own hashing function if DefaultHasher is not what you expect
function HashFile(const FileName: TFileName; Hasher: THasher=nil): cardinal;
/// hash one AnsiString content with the suppplied Hasher() function
function HashAnsiString(const Elem; Hasher: THasher): cardinal;
/// case-insensitive hash one AnsiString content with the suppplied Hasher() function
function HashAnsiStringI(const Elem; Hasher: THasher): cardinal;
/// hash one SynUnicode content with the suppplied Hasher() function
// - work with WideString for all Delphi versions, or UnicodeString in Delphi 2009+
function HashSynUnicode(const Elem; Hasher: THasher): cardinal;
/// case-insensitive hash one SynUnicode content with the suppplied Hasher() function
// - work with WideString for all Delphi versions, or UnicodeString in Delphi 2009+
function HashSynUnicodeI(const Elem; Hasher: THasher): cardinal;
/// hash one WideString content with the suppplied Hasher() function
// - work with WideString for all Delphi versions
function HashWideString(const Elem; Hasher: THasher): cardinal;
/// case-insensitive hash one WideString content with the suppplied Hasher() function
// - work with WideString for all Delphi versions
function HashWideStringI(const Elem; Hasher: THasher): cardinal;
{$ifdef UNICODE}
/// hash one UnicodeString content with the suppplied Hasher() function
// - work with UnicodeString in Delphi 2009+
function HashUnicodeString(const Elem; Hasher: THasher): cardinal;
/// case-insensitive hash one UnicodeString content with the suppplied Hasher() function
// - work with UnicodeString in Delphi 2009+
function HashUnicodeStringI(const Elem; Hasher: THasher): cardinal;
{$endif UNICODE}
{$ifndef NOVARIANTS}
/// case-sensitive hash one variant content with the suppplied Hasher() function
function HashVariant(const Elem; Hasher: THasher): cardinal;
/// case-insensitive hash one variant content with the suppplied Hasher() function
function HashVariantI(const Elem; Hasher: THasher): cardinal;
{$endif NOVARIANTS}
/// hash one PtrUInt (=NativeUInt) value with the suppplied Hasher() function
function HashPtrUInt(const Elem; Hasher: THasher): cardinal;
/// hash one Byte value
function HashByte(const Elem; Hasher: THasher): cardinal;
/// hash one Word value
function HashWord(const Elem; Hasher: THasher): cardinal;
/// hash one Integer/cardinal value - simply return the value ignore Hasher() parameter
function HashInteger(const Elem; Hasher: THasher): cardinal;
/// hash one Int64/Qword value with the suppplied Hasher() function
function HashInt64(const Elem; Hasher: THasher): cardinal;
/// hash one THash128 value with the suppplied Hasher() function
function Hash128(const Elem; Hasher: THasher): cardinal;
/// hash one THash256 value with the suppplied Hasher() function
function Hash256(const Elem; Hasher: THasher): cardinal;
/// hash one THash512 value with the suppplied Hasher() function
function Hash512(const Elem; Hasher: THasher): cardinal;
/// hash one pointer value with the suppplied Hasher() function
// - this version is not the same as HashPtrUInt, since it will always
// use the hasher function
function HashPointer(const Elem; Hasher: THasher): cardinal;
var
/// helper array to get the comparison function corresponding to a given
// standard array type
// - e.g. as DYNARRAY_SORTFIRSTFIELD[CaseInSensitive,djRawUTF8]
// - not to be used as such, but e.g. when inlining TDynArray methods
DYNARRAY_SORTFIRSTFIELD: array[boolean,TDynArrayKind] of TDynArraySortCompare = (
(nil, SortDynArrayBoolean, SortDynArrayByte, SortDynArrayWord,
SortDynArrayInteger, SortDynArrayCardinal, SortDynArraySingle,
SortDynArrayInt64, SortDynArrayQWord, SortDynArrayDouble,
SortDynArrayInt64, SortDynArrayInt64, SortDynArrayDouble, SortDynArrayDouble,
SortDynArrayAnsiString, SortDynArrayAnsiString, SortDynArrayString,
SortDynArrayRawByteString, SortDynArrayUnicodeString,
SortDynArrayUnicodeString, SortDynArray128, SortDynArray256,
SortDynArray512, SortDynArrayPointer,
{$ifndef NOVARIANTS}SortDynArrayVariant,{$endif} nil),
(nil, SortDynArrayBoolean, SortDynArrayByte, SortDynArrayWord,
SortDynArrayInteger, SortDynArrayCardinal, SortDynArraySingle,
SortDynArrayInt64, SortDynArrayQWord, SortDynArrayDouble,
SortDynArrayInt64, SortDynArrayInt64, SortDynArrayDouble, SortDynArrayDouble,
SortDynArrayAnsiStringI, SortDynArrayAnsiStringI, SortDynArrayStringI,
SortDynArrayRawByteString, SortDynArrayUnicodeStringI,
SortDynArrayUnicodeStringI, SortDynArray128, SortDynArray256,
SortDynArray512, SortDynArrayPointer,
{$ifndef NOVARIANTS}SortDynArrayVariantI,{$endif} nil));
/// helper array to get the hashing function corresponding to a given
// standard array type
// - e.g. as DYNARRAY_HASHFIRSTFIELD[CaseInSensitive,djRawUTF8]
// - not to be used as such, but e.g. when inlining TDynArray methods
DYNARRAY_HASHFIRSTFIELD: array[boolean,TDynArrayKind] of TDynArrayHashOne = (
(nil, HashByte, HashByte, HashWord, HashInteger,
HashInteger, HashInteger, HashInt64, HashInt64, HashInt64,
HashInt64, HashInt64, HashInt64, HashInt64,
HashAnsiString, HashAnsiString,
{$ifdef UNICODE}HashUnicodeString{$else}HashAnsiString{$endif},
HashAnsiString, HashWideString, HashSynUnicode, Hash128,
Hash256, Hash512, HashPointer,
{$ifndef NOVARIANTS}HashVariant,{$endif} nil),
(nil, HashByte, HashByte, HashWord, HashInteger,
HashInteger, HashInteger, HashInt64, HashInt64, HashInt64,
HashInt64, HashInt64, HashInt64, HashInt64,
HashAnsiStringI, HashAnsiStringI,
{$ifdef UNICODE}HashUnicodeStringI{$else}HashAnsiStringI{$endif},
HashAnsiStringI, HashWideStringI, HashSynUnicodeI, Hash128,
Hash256, Hash512, HashPointer,
{$ifndef NOVARIANTS}HashVariantI,{$endif} nil));
/// initialize the structure with a one-dimension dynamic array
// - the dynamic array must have been defined with its own type
// (e.g. TIntegerDynArray = array of Integer)
// - if aCountPointer is set, it will be used instead of length() to store
// the dynamic array items count - it will be much faster when adding
// elements to the array, because the dynamic array won't need to be
// resized each time - but in this case, you should use the Count property
// instead of length(array) or high(array) when accessing the data: in fact
// length(array) will store the memory size reserved, not the items count
// - if aCountPointer is set, its content will be set to 0, whatever the
// array length is, or the current aCountPointer^ value is
// - a typical usage could be:
// !var IntArray: TIntegerDynArray;
// !begin
// ! with DynArray(TypeInfo(TIntegerDynArray),IntArray) do
// ! begin
// ! (...)
// ! end;
// ! (...)
// ! DynArray(TypeInfo(TIntegerDynArray),IntArrayA).SaveTo
function DynArray(aTypeInfo: pointer; var aValue; aCountPointer: PInteger=nil): TDynArray;
{$ifdef HASINLINE}inline;{$endif}
/// wrap a simple dynamic array BLOB content as stored by TDynArray.SaveTo
// - a "simple" dynamic array contains data with no reference count, e.g. byte,
// word, integer, cardinal, Int64, double or Currency
// - same as TDynArray.LoadFrom() with no memory allocation nor memory copy: so
// is much faster than creating a temporary dynamic array to load the data
// - will return nil if no or invalid data, or a pointer to the data
// array otherwise, with the items number stored in Count and the individual
// element size in ElemSize (e.g. 2 for a TWordDynArray)
function SimpleDynArrayLoadFrom(Source: PAnsiChar; aTypeInfo: pointer;
var Count, ElemSize: integer; NoHash32Check: boolean=false): pointer;
/// wrap an Integer dynamic array BLOB content as stored by TDynArray.SaveTo
// - same as TDynArray.LoadFrom() with no memory allocation nor memory copy: so
// is much faster than creating a temporary dynamic array to load the data
// - will return nil if no or invalid data, or a pointer to the integer
// array otherwise, with the items number stored in Count
// - sligtly faster than SimpleDynArrayLoadFrom(Source,TypeInfo(TIntegerDynArray),Count)
function IntegerDynArrayLoadFrom(Source: PAnsiChar; var Count: integer;
NoHash32Check: boolean=false): PIntegerArray;
/// search in a RawUTF8 dynamic array BLOB content as stored by TDynArray.SaveTo
// - same as search within TDynArray.LoadFrom() with no memory allocation nor
// memory copy: so is much faster
// - will return -1 if no match or invalid data, or the matched entry index
function RawUTF8DynArrayLoadFromContains(Source: PAnsiChar;
Value: PUTF8Char; ValueLen: PtrInt; CaseSensitive: boolean): PtrInt;
{ ****************** text buffer and JSON functions and classes ************ }
const
/// maximum number of fields in a database Table
// - is included in SynCommons so that all DB-related work will be able to
// share the same low-level types and functions (e.g. TSQLFieldBits,
// TJSONWriter, TSynTableStatement, TSynTable, TSQLRecordProperties)
// - default is 64, but can be set to any value (64, 128, 192 and 256 optimized)
// changing the source below or using MAX_SQLFIELDS_128, MAX_SQLFIELDS_192 or
// MAX_SQLFIELDS_256 conditional directives for your project
// - this constant is used internaly to optimize memory usage in the
// generated asm code, and statically allocate some arrays for better speed
// - note that due to compiler restriction, 256 is the maximum value
// (this is the maximum number of items in a Delphi/FPC set)
{$ifdef MAX_SQLFIELDS_128}
MAX_SQLFIELDS = 128;
{$else}
{$ifdef MAX_SQLFIELDS_192}
MAX_SQLFIELDS = 192;
{$else}
{$ifdef MAX_SQLFIELDS_256}
MAX_SQLFIELDS = 256;
{$else}
MAX_SQLFIELDS = 64;
{$endif}
{$endif}
{$endif}
/// sometimes, the ID field is included in a bits set
MAX_SQLFIELDS_INCLUDINGID = MAX_SQLFIELDS+1;
/// UTF-8 encoded \uFFF0 special code to mark Base64 binary content in JSON
// - Unicode special char U+FFF0 is UTF-8 encoded as EF BF B0 bytes
// - as generated by BinToBase64WithMagic() functions, and expected by
// SQLParamContent() and ExtractInlineParameters() functions
// - used e.g. when transmitting TDynArray.SaveTo() content
JSON_BASE64_MAGIC = $b0bfef;
/// '"' + UTF-8 encoded \uFFF0 special code to mark Base64 binary in JSON
JSON_BASE64_MAGIC_QUOTE = ord('"')+cardinal(JSON_BASE64_MAGIC) shl 8;
/// '"' + UTF-8 encoded \uFFF0 special code to mark Base64 binary in JSON
// - defined as a cardinal variable to be used as:
// ! AddNoJSONEscape(@JSON_BASE64_MAGIC_QUOTE_VAR,4);
JSON_BASE64_MAGIC_QUOTE_VAR: cardinal = JSON_BASE64_MAGIC_QUOTE;
/// UTF-8 encoded \uFFF1 special code to mark ISO-8601 SQLDATE in JSON
// - e.g. '"\uFFF12012-05-04"' pattern
// - Unicode special char U+FFF1 is UTF-8 encoded as EF BF B1 bytes
// - as generated by DateToSQL/DateTimeToSQL/TimeLogToSQL functions, and
// expected by SQLParamContent() and ExtractInlineParameters() functions
JSON_SQLDATE_MAGIC = $b1bfef;
/// '"' + UTF-8 encoded \uFFF1 special code to mark ISO-8601 SQLDATE in JSON
JSON_SQLDATE_MAGIC_QUOTE = ord('"')+cardinal(JSON_SQLDATE_MAGIC) shl 8;
///'"' + UTF-8 encoded \uFFF1 special code to mark ISO-8601 SQLDATE in JSON
// - defined as a cardinal variable to be used as:
// ! AddNoJSONEscape(@JSON_SQLDATE_MAGIC_QUOTE_VAR,4);
JSON_SQLDATE_MAGIC_QUOTE_VAR: cardinal = JSON_SQLDATE_MAGIC_QUOTE;
type
TTextWriter = class;
TTextWriterWithEcho = class;
/// method prototype for custom serialization of a dynamic array item
// - each element of the dynamic array will be called as aValue parameter
// of this callback
// - can be used also at record level, if the record has a type information
// (i.e. shall contain a managed type within its fields)
// - to be used with TTextWriter.RegisterCustomJSONSerializer() method
// - note that the generated JSON content will be appended after a '[' and
// before a ']' as a normal JSON arrray, but each item can be any JSON
// structure (i.e. a number, a string, but also an object or an array)
// - implementation code could call aWriter.Add/AddJSONEscapeString...
// - implementation code shall follow the same exact format for the
// associated TDynArrayJSONCustomReader callback
TDynArrayJSONCustomWriter = procedure(const aWriter: TTextWriter; const aValue) of object;
/// method prototype for custom unserialization of a dynamic array item
// - each element of the dynamic array will be called as aValue parameter
// of this callback
// - can be used also at record level, if the record has a type information
// (i.e. shall contain a managed type within its fields)
// - to be used with TTextWriter.RegisterCustomJSONSerializer() method
// - implementation code could call e.g. GetJSONField() low-level function, and
// returns a pointer to the last handled element of the JSON input buffer,
// as such (aka EndOfBuffer variable as expected by GetJSONField):
// ! var V: TFV absolute aValue;
// ! begin
// ! (...)
// ! V.Detailed := UTF8ToString(GetJSONField(P,P));
// ! if P=nil then
// ! exit;
// ! aValid := true;
// ! result := P; // ',' or ']' for last item of array
// ! end;
// - implementation code shall follow the same exact format for the
// associated TDynArrayJSONCustomWriter callback
TDynArrayJSONCustomReader = function(P: PUTF8Char; var aValue; out aValid: Boolean
{$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char of object;
/// the kind of variables handled by TJSONCustomParser
// - the last item should be ptCustom, for non simple types
TJSONCustomParserRTTIType = (
ptArray, ptBoolean, ptByte, ptCardinal, ptCurrency, ptDouble, ptExtended,
ptInt64, ptInteger, ptQWord, ptRawByteString, ptRawJSON, ptRawUTF8, ptRecord,
ptSingle, ptString, ptSynUnicode, ptDateTime, ptDateTimeMS, ptGUID,
ptID, ptTimeLog, {$ifdef HASVARUSTRING} ptUnicodeString, {$endif}
{$ifndef NOVARIANTS} ptVariant, {$endif} ptWideString, ptWord, ptCustom);
/// how TJSONCustomParser would serialize/unserialize JSON content
TJSONCustomParserSerializationOption = (
soReadIgnoreUnknownFields, soWriteHumanReadable,
soCustomVariantCopiedByReference, soWriteIgnoreDefault);
/// how TJSONCustomParser would serialize/unserialize JSON content
// - by default, during reading any unexpected field will stop and fail the
// process - if soReadIgnoreUnknownFields is defined, such properties will
// be ignored (can be very handy when parsing JSON from a remote service)
// - by default, JSON content will be written in its compact standard form,
// ready to be parsed by any client - you can specify soWriteHumanReadable
// so that some line feeds and indentation will make the content more readable
// - by default, internal TDocVariant variants will be copied by-value from
// one instance to another, to ensure proper safety - but it may be too slow:
// if you set soCustomVariantCopiedByReference, any internal
// TDocVariantData.VValue/VName instances will be copied by-reference,
// to avoid memory allocations, BUT it may break internal process if you change
// some values in place (since VValue/VName and VCount won't match) - as such,
// if you set this option, ensure that you use the content as read-only
// - by default, all fields are persistented, unless soWriteIgnoreDefault is
// defined and void values (e.g. "" or 0) won't be written
// - you may use TTextWriter.RegisterCustomJSONSerializerSetOptions() class
// method to customize the serialization for a given type
TJSONCustomParserSerializationOptions = set of TJSONCustomParserSerializationOption;
TJSONCustomParserRTTI = class;
/// an array of RTTI properties information
// - we use dynamic arrays, since all the information is static and we
// do not need to remove any RTTI information
TJSONCustomParserRTTIs = array of TJSONCustomParserRTTI;
/// used to store additional RTTI in TJSONCustomParser internal structures
TJSONCustomParserRTTI = class
protected
fPropertyName: RawUTF8;
fFullPropertyName: RawUTF8;
fPropertyType: TJSONCustomParserRTTIType;
fCustomTypeName: RawUTF8;
fNestedProperty: TJSONCustomParserRTTIs;
fDataSize: integer;
fNestedDataSize: integer;
procedure ComputeDataSizeAfterAdd; virtual;
procedure ComputeNestedDataSize;
procedure ComputeFullPropertyName;
procedure FinalizeNestedRecord(var Data: PByte);
procedure FinalizeNestedArray(var Data: PtrUInt);
procedure AllocateNestedArray(var Data: PtrUInt; NewLength: integer);
procedure ReAllocateNestedArray(var Data: PtrUInt; NewLength: integer);
function IfDefaultSkipped(var Value: PByte): boolean;
procedure WriteOneSimpleValue(aWriter: TTextWriter; var Value: PByte;
Options: TJSONCustomParserSerializationOptions);
public
/// initialize the instance
constructor Create(const aPropertyName: RawUTF8;
aPropertyType: TJSONCustomParserRTTIType);
/// initialize an instance from the RTTI type information
// - will return an instance of this class of any inherited class
class function CreateFromRTTI(const PropertyName: RawUTF8;
Info: pointer; ItemSize: integer): TJSONCustomParserRTTI;
/// create an instance from a specified type name
// - will return an instance of this class of any inherited class
class function CreateFromTypeName(const aPropertyName,
aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI;
/// recognize a simple type from a supplied type name
// - will return ptCustom for any unknown type
// - see also TypeInfoToRttiType() function
class function TypeNameToSimpleRTTIType(
const TypeName: RawUTF8): TJSONCustomParserRTTIType; overload;
/// recognize a simple type from a supplied type name
// - will return ptCustom for any unknown type
// - see also TypeInfoToRttiType() function
class function TypeNameToSimpleRTTIType(
TypeName: PShortString): TJSONCustomParserRTTIType; overload;
/// recognize a simple type from a supplied type name
// - will return ptCustom for any unknown type
// - see also TypeInfoToRttiType() function
class function TypeNameToSimpleRTTIType(TypeName: PUTF8Char; TypeNameLen: PtrInt;
ItemTypeName: PRawUTF8): TJSONCustomParserRTTIType; overload;
/// recognize a simple type from a supplied type information
// - to be called if TypeNameToSimpleRTTIType() did fail, i.e. return ptCustom
// - will return ptCustom for any complex type (e.g. a record)
// - see also TypeInfoToRttiType() function
class function TypeInfoToSimpleRTTIType(Info: pointer): TJSONCustomParserRTTIType;
/// recognize a ktBinary simple type from a supplied type name
// - as registered by TTextWriter.RegisterCustomJSONSerializerFromTextBinaryType
class function TypeNameToSimpleBinary(const aTypeName: RawUTF8;
out aDataSize, aFieldSize: integer): boolean;
/// unserialize some JSON content into its binary internal representation
// - on error, returns false and P should point to the faulty text input
function ReadOneLevel(var P: PUTF8Char; var Data: PByte;
Options: TJSONCustomParserSerializationOptions{$ifndef NOVARIANTS};
CustomVariantOptions: PDocVariantOptions{$endif}): boolean; virtual;
/// serialize a binary internal representation into JSON content
// - this method won't append a trailing ',' character
procedure WriteOneLevel(aWriter: TTextWriter; var P: PByte;
Options: TJSONCustomParserSerializationOptions); virtual;
/// the associated type name, e.g. for a record
property CustomTypeName: RawUTF8 read fCustomTypeName;
/// the property name
// - may be void for the Root element
// - e.g. 'SubProp'
property PropertyName: RawUTF8 read fPropertyName;
/// the property name, including all parent elements
// - may be void for the Root element
// - e.g. 'MainProp.SubProp'
property FullPropertyName: RawUTF8 read fFullPropertyName;
/// the property type
// - support only a limited set of simple types, or ptRecord for a nested
// record, or ptArray for a nested array
property PropertyType: TJSONCustomParserRTTIType read fPropertyType;
/// the nested array of properties (if any)
// - assigned only if PropertyType is [ptRecord,ptArray]
// - is either the record type of each ptArray item:
// ! SubProp: array of record ...
// - or one NestedProperty[0] entry with PropertyName='' and PropertyType
// not in [ptRecord,ptArray]:
// ! SubPropNumber: array of integer;
// ! SubPropText: array of RawUTF8;
property NestedProperty: TJSONCustomParserRTTIs read fNestedProperty;
end;
/// used to store additional RTTI as a ptCustom kind of property
TJSONCustomParserCustom = class(TJSONCustomParserRTTI)
protected
fCustomTypeInfo: pointer;
public
/// initialize the instance
constructor Create(const aPropertyName, aCustomTypeName: RawUTF8); virtual;
/// abstract method to write the instance as JSON
procedure CustomWriter(const aWriter: TTextWriter; const aValue); virtual; abstract;
/// abstract method to read the instance from JSON
// - should return nil on parsing error
function CustomReader(P: PUTF8Char; var aValue; out EndOfObject: AnsiChar{$ifndef NOVARIANTS};
CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; virtual; abstract;
/// release any memory used by the instance
procedure FinalizeItem(Data: Pointer); virtual;
/// the associated RTTI structure
property CustomTypeInfo: pointer read fCustomTypeInfo;
end;
/// which kind of property does TJSONCustomParserCustomSimple refer to
TJSONCustomParserCustomSimpleKnownType = (
ktNone, ktEnumeration, ktSet, ktGUID,
ktFixedArray, ktStaticArray, ktDynamicArray, ktBinary);
/// used to store additional RTTI for simple type as a ptCustom kind
// - this class handle currently enumerate, TGUID or static/dynamic arrays
TJSONCustomParserCustomSimple = class(TJSONCustomParserCustom)
protected
fKnownType: TJSONCustomParserCustomSimpleKnownType;
fTypeData: pointer;
fFixedSize: integer;
fNestedArray: TJSONCustomParserRTTI;
public
/// initialize the instance from the given RTTI structure
constructor Create(const aPropertyName, aCustomTypeName: RawUTF8;
aCustomType: pointer); reintroduce;
/// initialize the instance for a static array
constructor CreateFixedArray(const aPropertyName: RawUTF8;
aFixedSize: cardinal);
/// initialize the instance for a binary blob
constructor CreateBinary(const aPropertyName: RawUTF8;
aDataSize, aFixedSize: cardinal);
/// released used memory
destructor Destroy; override;
/// method to write the instance as JSON
procedure CustomWriter(const aWriter: TTextWriter; const aValue); override;
/// method to read the instance from JSON
function CustomReader(P: PUTF8Char; var aValue; out EndOfObject: AnsiChar{$ifndef NOVARIANTS};
CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; override;
/// which kind of simple property this instance does refer to
property KnownType: TJSONCustomParserCustomSimpleKnownType read fKnownType;
/// the element type for ktStaticArray and ktDynamicArray
property NestedArray: TJSONCustomParserRTTI read fNestedArray;
end;
/// implement a reference to a registered record type
// - i.e. ptCustom kind of property, handled by the
// TTextWriter.RegisterCustomJSONSerializer*() internal list
TJSONCustomParserCustomRecord = class(TJSONCustomParserCustom)
protected
fCustomTypeIndex: integer;
function GetJSONCustomParserRegistration: pointer;
public
/// initialize the instance from the given record custom serialization index
constructor Create(const aPropertyName: RawUTF8;
aCustomTypeIndex: integer); reintroduce; overload;
/// method to write the instance as JSON
procedure CustomWriter(const aWriter: TTextWriter; const aValue); override;
/// method to read the instance from JSON
function CustomReader(P: PUTF8Char; var aValue; out EndOfObject: AnsiChar{$ifndef NOVARIANTS};
CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; override;
/// release any memory used by the instance
procedure FinalizeItem(Data: Pointer); override;
end;
/// how an RTTI expression is expected to finish
TJSONCustomParserRTTIExpectedEnd = (eeNothing, eeSquare, eeCurly, eeEndKeyWord);
TJSONRecordAbstract = class;
/// used to handle additional RTTI for JSON record serialization
// - this class is used to define how a record is defined, and will work
// with any version of Delphi
// - this Abstract class is not to be used as-this, but contains all
// needed information to provide CustomWriter/CustomReader methods
// - you can use e.g. TJSONRecordTextDefinition for text-based RTTI
// manual definition, or (not yet provided) a version based on Delphi 2010+
// new RTTI information
TJSONRecordAbstract = class
protected
/// internal storage of TJSONCustomParserRTTI instances
fItems: TSynObjectList;
fRoot: TJSONCustomParserRTTI;
fOptions: TJSONCustomParserSerializationOptions;
function AddItem(const aPropertyName: RawUTF8; aPropertyType: TJSONCustomParserRTTIType;
const aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI;
public
/// initialize the class instance
constructor Create;
/// callback for custom JSON serialization
// - will follow the RTTI textual information as supplied to the constructor
procedure CustomWriter(const aWriter: TTextWriter; const aValue);
/// callback for custom JSON unserialization
// - will follow the RTTI textual information as supplied to the constructor
function CustomReader(P: PUTF8Char; var aValue; out aValid: Boolean{$ifndef NOVARIANTS};
CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char;
/// release used memory
// - when created via Compute() call, instances of this class are managed
// via a GarbageCollector() global list, so you do not need to free them
destructor Destroy; override;
/// store the RTTI information of properties at root level
// - is one instance with PropertyType=ptRecord and PropertyName=''
property Root: TJSONCustomParserRTTI read fRoot;
/// how this class would serialize/unserialize JSON content
// - by default, no option is defined
// - you can customize the expected options with the instance returned by
// TTextWriter.RegisterCustomJSONSerializerFromText() method, or via the
// TTextWriter.RegisterCustomJSONSerializerSetOptions() overloaded methods
property Options: TJSONCustomParserSerializationOptions read fOptions write fOptions;
end;
/// used to handle JSON record serialization using RTTI
// - is able to handle any kind of record since Delphi 2010, thanks to
// enhanced RTTI
TJSONRecordRTTI = class(TJSONRecordAbstract)
protected
fRecordTypeInfo: pointer;
function AddItemFromRTTI(const PropertyName: RawUTF8;
Info: pointer; ItemSize: integer): TJSONCustomParserRTTI;
{$ifdef ISDELPHI2010}
procedure FromEnhancedRTTI(Props: TJSONCustomParserRTTI; Info: pointer);
{$endif}
public
/// initialize the instance
// - you should NOT use this constructor directly, but let e.g.
// TJSONCustomParsers.TryToGetFromRTTI() create it for you
constructor Create(aRecordTypeInfo: pointer; aRoot: TJSONCustomParserRTTI); reintroduce;
/// the low-level address of the enhanced RTTI
property RecordTypeInfo: pointer read fRecordTypeInfo;
end;
/// used to handle text-defined additional RTTI for JSON record serialization
// - is used by TTextWriter.RegisterCustomJSONSerializerFromText() method
TJSONRecordTextDefinition = class(TJSONRecordAbstract)
protected
fDefinition: RawUTF8;
procedure Parse(Props: TJSONCustomParserRTTI; var P: PUTF8Char;
PEnd: TJSONCustomParserRTTIExpectedEnd);
public
/// initialize a custom JSON serializer/unserializer from pseudo RTTI
// - you should NOT use this constructor directly, but call the FromCache()
// class function, which will use an internal definition cache
constructor Create(aRecordTypeInfo: pointer; const aDefinition: RawUTF8); reintroduce;
/// retrieve a custom cached JSON serializer/unserializer from pseudo RTTI
// - returned class instance will be cached for any further use
// - the record where the data will be stored should be defined as PACKED:
// ! type TMyRecord = packed record
// ! A,B,C: integer;
// ! D: RawUTF8;
// ! E: record; // or array of record/integer/string/...
// ! E1,E2: double;
// ! end;
// ! end;
// - only known sub types are integer, cardinal, Int64, single, double,
// currency, TDateTime, TTimeLog, RawUTF8, String, WideString, SynUnicode,
// or a nested record or dynamic array
// - RTTI textual information shall be supplied as text, with the
// same format as with a pascal record, or with some shorter variations:
// ! FromCache('A,B,C: integer; D: RawUTF8; E: record E1,E2: double; end;');
// ! FromCache('A,B,C: integer; D: RawUTF8; E: array of record E1,E2: double; end;');
// ! 'A,B,C: integer; D: RawUTF8; E: array of SynUnicode; F: array of integer'
// or a shorter alternative syntax for records and arrays:
// ! FromCache('A,B,C: integer; D: RawUTF8; E: {E1,E2: double}');
// ! FromCache('A,B,C: integer; D: RawUTF8; E: [E1,E2: double]');
// in fact ; could be ignored:
// ! FromCache('A,B,C:integer D:RawUTF8 E:{E1,E2:double}');
// ! FromCache('A,B,C:integer D:RawUTF8 E:[E1,E2:double]');
// or even : could be ignored:
// ! FromCache('A,B,C integer D RawUTF8 E{E1,E2 double}');
// ! FromCache('A,B,C integer D RawUTF8 E[E1,E2 double]');
class function FromCache(aTypeInfo: pointer;
const aDefinition: RawUTF8): TJSONRecordTextDefinition;
/// the textual definition of this RTTI information
property Definition: RawUTF8 read fDefinition;
end;
/// the available logging events, as handled by TSynLog
// - defined in SynCommons so that it may be used with TTextWriter.AddEndOfLine
// - sllInfo will log general information events
// - sllDebug will log detailed debugging information
// - sllTrace will log low-level step by step debugging information
// - sllWarning will log unexpected values (not an error)
// - sllError will log errors
// - sllEnter will log every method start
// - sllLeave will log every method exit
// - sllLastError will log the GetLastError OS message
// - sllException will log all exception raised - available since Windows XP
// - sllExceptionOS will log all OS low-level exceptions (EDivByZero,
// ERangeError, EAccessViolation...)
// - sllMemory will log memory statistics
// - sllStackTrace will log caller's stack trace (it's by default part of
// TSynLogFamily.LevelStackTrace like sllError, sllException, sllExceptionOS,
// sllLastError and sllFail)
// - sllFail was defined for TSynTestsLogged.Failed method, and can be used
// to log some customer-side assertions (may be notifications, not errors)
// - sllSQL is dedicated to trace the SQL statements
// - sllCache should be used to trace the internal caching mechanism
// - sllResult could trace the SQL results, JSON encoded
// - sllDB is dedicated to trace low-level database engine features
// - sllHTTP could be used to trace HTTP process
// - sllClient/sllServer could be used to trace some Client or Server process
// - sllServiceCall/sllServiceReturn to trace some remote service or library
// - sllUserAuth to trace user authentication (e.g. for individual requests)
// - sllCustom* items can be used for any purpose
// - sllNewRun will be written when a process opens a rotated log
// - sllDDDError will log any DDD-related low-level error information
// - sllDDDInfo will log any DDD-related low-level debugging information
// - sllMonitoring will log the statistics information (if available),
// or may be used for real-time chat among connected people to ToolsAdmin
TSynLogInfo = (
sllNone, sllInfo, sllDebug, sllTrace, sllWarning, sllError,
sllEnter, sllLeave,
sllLastError, sllException, sllExceptionOS, sllMemory, sllStackTrace,
sllFail, sllSQL, sllCache, sllResult, sllDB, sllHTTP, sllClient, sllServer,
sllServiceCall, sllServiceReturn, sllUserAuth,
sllCustom1, sllCustom2, sllCustom3, sllCustom4, sllNewRun,
sllDDDError, sllDDDInfo, sllMonitoring);
/// used to define a set of logging level abilities
// - i.e. a combination of none or several logging event
// - e.g. use LOG_VERBOSE constant to log all events, or LOG_STACKTRACE
// to log all errors and exceptions
TSynLogInfos = set of TSynLogInfo;
/// a dynamic array of logging event levels
TSynLogInfoDynArray = array of TSynLogInfo;
/// event signature for TTextWriter.OnFlushToStream callback
TOnTextWriterFlush = procedure(Text: PUTF8Char; Len: PtrInt) of object;
/// available options for TTextWriter.WriteObject() method
// - woHumanReadable will add some line feeds and indentation to the content,
// to make it more friendly to the human eye
// - woDontStoreDefault (which is set by default for WriteObject method) will
// avoid serializing properties including a default value (JSONToObject function
// will set the default values, so it may help saving some bandwidth or storage)
// - woFullExpand will generate a debugger-friendly layout, including instance
// class name, sets/enumerates as text, and reference pointer - as used by
// TSynLog and ObjectToJSONFull()
// - woStoreClassName will add a "ClassName":"TMyClass" field
// - woStorePointer will add a "Address":"0431298A" field, and .map/.mab
// source code line number corresponding to ESynException.RaisedAt
// - woStoreStoredFalse will write the 'stored false' properties, even
// if they are marked as such (used e.g. to persist all settings on file,
// but disallow the sensitive - password - fields be logged)
// - woHumanReadableFullSetsAsStar will store an human-readable set with
// all its enumerates items set to be stored as ["*"]
// - woHumanReadableEnumSetAsComment will add a comment at the end of the
// line, containing all available values of the enumaration or set, e.g:
// $ "Enum": "Destroying", // Idle,Started,Finished,Destroying
// - woEnumSetsAsText will store sets and enumerables as text (is also
// included in woFullExpand or woHumanReadable)
// - woDateTimeWithMagic will append the JSON_SQLDATE_MAGIC (i.e. U+FFF1)
// before the ISO-8601 encoded TDateTime value
// - woDateTimeWithZSuffix will append the Z suffix to the ISO-8601 encoded
// TDateTime value, to identify the content as strict UTC value
// - TTimeLog would be serialized as Int64, unless woTimeLogAsText is defined
// - since TSQLRecord.ID could be huge Int64 numbers, they may be truncated
// on client side, e.g. to 53-bit range in JavaScript: you could define
// woIDAsIDstr to append an additional "ID_str":"##########" field
// - by default, TSQLRawBlob properties are serialized as null, unless
// woSQLRawBlobAsBase64 is defined
// - if woHideSynPersistentPassword is set, TSynPersistentWithPassword.Password
// field will be serialized as "***" to prevent security issues (e.g. in log)
// - by default, TObjectList will set the woStoreClassName for its nested
// objects, unless woObjectListWontStoreClassName is defined
// - void strings would be serialized as "", unless woDontStoreEmptyString
// is defined so that such properties would not be written
// - all inherited properties would be serialized, unless woDontStoreInherited
// is defined, and only the topmost class level properties would be serialized
// - woInt64AsHex will force Int64/QWord to be written as hexadecimal string -
// see j2oAllowInt64Hex reverse option fot Json2Object
// - woDontStore0 will avoid serializating number properties equal to 0
TTextWriterWriteObjectOption = (
woHumanReadable, woDontStoreDefault, woFullExpand,
woStoreClassName, woStorePointer, woStoreStoredFalse,
woHumanReadableFullSetsAsStar, woHumanReadableEnumSetAsComment,
woEnumSetsAsText, woDateTimeWithMagic, woDateTimeWithZSuffix, woTimeLogAsText,
woIDAsIDstr, woSQLRawBlobAsBase64, woHideSynPersistentPassword,
woObjectListWontStoreClassName, woDontStoreEmptyString,
woDontStoreInherited, woInt64AsHex, woDontStore0);
/// options set for TTextWriter.WriteObject() method
TTextWriterWriteObjectOptions = set of TTextWriterWriteObjectOption;
/// callback used to echo each line of TTextWriter class
// - should return TRUE on success, FALSE if the log was not echoed: but
// TSynLog will continue logging, even if this event returned FALSE
TOnTextWriterEcho = function(Sender: TTextWriter; Level: TSynLogInfo;
const Text: RawUTF8): boolean of object;
/// callback used by TTextWriter.WriteObject to customize class instance
// serialization
// - should return TRUE if the supplied property has been written (including
// the property name and the ending ',' character), and doesn't need to be
// processed with the default RTTI-based serializer
TOnTextWriterObjectProp = function(Sender: TTextWriter; Value: TObject;
PropInfo: pointer; Options: TTextWriterWriteObjectOptions): boolean of object;
/// the potential places were TTextWriter.AddHtmlEscape should process
// proper HTML string escaping, unless hfNone is used
// $ < > & " -> &lt; &gt; &amp; &quote;
// by default (hfAnyWhere)
// $ < > & -> &lt; &gt; &amp;
// outside HTML attributes (hfOutsideAttributes)
// $ & " -> &amp; &quote;
// within HTML attributes (hfWithinAttributes)
TTextWriterHTMLFormat = (
hfNone, hfAnyWhere, hfOutsideAttributes, hfWithinAttributes);
/// available global options for a TTextWriter instance
// - TTextWriter.WriteObject() method behavior would be set via their own
// TTextWriterWriteObjectOptions, and work in conjunction with those settings
// - twoStreamIsOwned would be set if the associated TStream is owned by
// the TTextWriter instance
// - twoFlushToStreamNoAutoResize would forbid FlushToStream to resize the
// internal memory buffer when it appears undersized - FlushFinal will set it
// before calling a last FlushToStream
// - by default, custom serializers defined via RegisterCustomJSONSerializer()
// would let AddRecordJSON() and AddDynArrayJSON() write enumerates and sets
// as integer numbers, unless twoEnumSetsAsTextInRecord or
// twoEnumSetsAsBooleanInRecord (exclusively) are set - for Mustache data
// context, twoEnumSetsAsBooleanInRecord will return a JSON object with
// "setname":true/false fields
// - variants and nested objects would be serialized with their default
// JSON serialization options, unless twoForceJSONExtended or
// twoForceJSONStandard is defined
// - when enumerates and sets are serialized as text into JSON, you may force
// the identifiers to be left-trimed for all their lowercase characters
// (e.g. sllError -> 'Error') by setting twoTrimLeftEnumSets: this option
// would default to the global TTextWriter.SetDefaultEnumTrim setting
// - twoEndOfLineCRLF would reflect the TTextWriter.EndOfLineCRLF property
// - twoBufferIsExternal would be set if the temporary buffer is not handled
// by the instance, but specified at constructor, maybe from the stack
// - twoIgnoreDefaultInRecord will force custom record serialization to avoid
// writing the fields with default values, i.e. enable soWriteIgnoreDefault
// when TJSONCustomParserRTTI.WriteOneLevel is called
// - twoDateTimeWithZ appends an ending 'Z' to TDateTime/TDateTimeMS values
TTextWriterOption = (
twoStreamIsOwned,
twoFlushToStreamNoAutoResize,
twoEnumSetsAsTextInRecord,
twoEnumSetsAsBooleanInRecord,
twoFullSetsAsStar,
twoTrimLeftEnumSets,
twoForceJSONExtended,
twoForceJSONStandard,
twoEndOfLineCRLF,
twoBufferIsExternal,
twoIgnoreDefaultInRecord,
twoDateTimeWithZ);
/// options set for a TTextWriter instance
// - allows to override e.g. AddRecordJSON() and AddDynArrayJSON() behavior;
// or set global process customization for a TTextWriter
TTextWriterOptions = set of TTextWriterOption;
/// may be used to allocate on stack a 8KB work buffer for a TTextWriter
// - via the TTextWriter.CreateOwnedStream overloaded constructor
TTextWriterStackBuffer = array[0..8191] of AnsiChar;
PTextWriterStackBuffer = ^TTextWriterStackBuffer;
/// simple writer to a Stream, specialized for the TEXT format
// - use an internal buffer, faster than string+string
// - some dedicated methods is able to encode any data with JSON/XML escape
// - see TTextWriterWithEcho below for optional output redirection (for TSynLog)
// - see SynTable.pas for SQL resultset export via TJSONWriter
// - see mORMot.pas for proper class serialization via TJSONSerializer.WriteObject
TTextWriter = class
protected
B, BEnd: PUTF8Char;
fStream: TStream;
fInitialStreamPosition: PtrUInt;
fTotalFileSize: PtrUInt;
fCustomOptions: TTextWriterOptions;
// internal temporary buffer
fTempBufSize: Integer;
fTempBuf: PUTF8Char;
fOnFlushToStream: TOnTextWriterFlush;
fOnWriteObject: TOnTextWriterObjectProp;
/// used by WriteObjectAsString/AddDynArrayJSONAsString methods
fInternalJSONWriter: TTextWriter;
fHumanReadableLevel: integer;
procedure WriteToStream(data: pointer; len: PtrUInt); virtual;
function GetTextLength: PtrUInt;
procedure SetStream(aStream: TStream);
procedure SetBuffer(aBuf: pointer; aBufSize: integer);
procedure InternalAddFixedAnsi(Source: PAnsiChar; SourceChars: Cardinal;
AnsiToWide: PWordArray; Escape: TTextWriterKind);
public
/// the data will be written to the specified Stream
// - aStream may be nil: in this case, it MUST be set before using any
// Add*() method
// - default internal buffer size if 8192
constructor Create(aStream: TStream; aBufSize: integer=8192); overload;
/// the data will be written to the specified Stream
// - aStream may be nil: in this case, it MUST be set before using any
// Add*() method
// - will use an external buffer (which may be allocated on stack)
constructor Create(aStream: TStream; aBuf: pointer; aBufSize: integer); overload;
/// the data will be written to an internal TRawByteStringStream
// - TRawByteStringStream.DataString method will be used by TTextWriter.Text
// to retrieve directly the content without any data move nor allocation
// - default internal buffer size if 4096 (enough for most JSON objects)
// - consider using a stack-allocated buffer and the overloaded method
constructor CreateOwnedStream(aBufSize: integer=4096); overload;
/// the data will be written to an internal TRawByteStringStream
// - will use an external buffer (which may be allocated on stack)
// - TRawByteStringStream.DataString method will be used by TTextWriter.Text
// to retrieve directly the content without any data move nor allocation
constructor CreateOwnedStream(aBuf: pointer; aBufSize: integer); overload;
/// the data will be written to an internal TRawByteStringStream
// - will use the stack-allocated TTextWriterStackBuffer if possible
// - TRawByteStringStream.DataString method will be used by TTextWriter.Text
// to retrieve directly the content without any data move nor allocation
constructor CreateOwnedStream(var aStackBuf: TTextWriterStackBuffer;
aBufSize: integer=SizeOf(TTextWriterStackBuffer)); overload;
/// the data will be written to an external file
// - you should call explicitly FlushFinal or FlushToStream to write
// any pending data to the file
constructor CreateOwnedFileStream(const aFileName: TFileName; aBufSize: integer=8192);
/// release all internal structures
// - e.g. free fStream if the instance was owned by this class
destructor Destroy; override;
/// allow to override the default JSON serialization of enumerations and
// sets as text, which would write the whole identifier (e.g. 'sllError')
// - calling SetDefaultEnumTrim(true) would force the enumerations to
// be trimmed for any lower case char, e.g. sllError -> 'Error'
// - this is global to the current process, and should be use mainly for
// compatibility purposes for the whole process
// - you may change the default behavior by setting twoTrimLeftEnumSets
// in the TTextWriter.CustomOptions property of a given serializer
// - note that unserialization process would recognize both formats
class procedure SetDefaultEnumTrim(aShouldTrimEnumsAsText: boolean);
/// retrieve the data as a string
function Text: RawUTF8;
{$ifdef HASINLINE}inline;{$endif}
/// retrieve the data as a string
// - will avoid creation of a temporary RawUTF8 variable as for Text function
procedure SetText(var result: RawUTF8; reformat: TTextWriterJSONFormat=jsonCompact);
/// set the internal stream content with the supplied UTF-8 text
procedure ForceContent(const text: RawUTF8);
/// write pending data to the Stream, with automatic buffer resizal
// - you should not have to call FlushToStream in most cases, but FlushFinal
// at the end of the process, just before using the resulting Stream
// - FlushToStream may be used to force immediate writing of the internal
// memory buffer to the destination Stream
// - you can set FlushToStreamNoAutoResize=true or call FlushFinal if you
// do not want the automatic memory buffer resizal to take place
procedure FlushToStream; virtual;
/// write pending data to the Stream, without automatic buffer resizal
// - will append the internal memory buffer to the Stream
// - in short, FlushToStream may be called during the adding process, and
// FlushFinal at the end of the process, just before using the resulting Stream
// - if you don't call FlushToStream or FlushFinal, some pending characters
// may not be copied to the Stream: you should call it before using the Stream
procedure FlushFinal;
/// gives access to an internal temporary TTextWriter
// - may be used to escape some JSON espaced value (i.e. escape it twice),
// in conjunction with AddJSONEscape(Source: TTextWriter)
function InternalJSONWriter: TTextWriter;
/// append one ASCII char to the buffer
procedure Add(c: AnsiChar); overload; {$ifdef HASINLINE}inline;{$endif}
/// append one ASCII char to the buffer, if not already there as LastChar
procedure AddOnce(c: AnsiChar); overload; {$ifdef HASINLINE}inline;{$endif}
/// append two chars to the buffer
procedure Add(c1,c2: AnsiChar); overload; {$ifdef HASINLINE}inline;{$endif}
{$ifndef CPU64} // already implemented by Add(Value: PtrInt) method
/// append a 64-bit signed Integer Value as text
procedure Add(Value: Int64); overload;
{$endif}
/// append a 32-bit signed Integer Value as text
procedure Add(Value: PtrInt); overload;
/// append a boolean Value as text
// - write either 'true' or 'false'
procedure Add(Value: boolean); overload; {$ifdef HASINLINE}inline;{$endif}
/// append a Currency from its Int64 in-memory representation
procedure AddCurr64(const Value: Int64); overload;
/// append a Currency from its Int64 in-memory representation
procedure AddCurr64(const Value: currency); overload; {$ifdef HASINLINE}inline;{$endif}
/// append a TTimeLog value, expanded as Iso-8601 encoded text
procedure AddTimeLog(Value: PInt64);
/// append a TUnixTime value, expanded as Iso-8601 encoded text
procedure AddUnixTime(Value: PInt64);
/// append a TUnixMSTime value, expanded as Iso-8601 encoded text
procedure AddUnixMSTime(Value: PInt64; WithMS: boolean=false);
/// append a TDateTime value, expanded as Iso-8601 encoded text
// - use 'YYYY-MM-DDThh:mm:ss' format (with FirstChar='T')
// - if twoDateTimeWithZ CustomOption is set, will append an ending 'Z'
// - if WithMS is TRUE, will append '.sss' for milliseconds resolution
// - if QuoteChar is not #0, it will be written before and after the date
procedure AddDateTime(Value: PDateTime; FirstChar: AnsiChar='T'; QuoteChar: AnsiChar=#0;
WithMS: boolean=false); overload;
/// append a TDateTime value, expanded as Iso-8601 encoded text
// - use 'YYYY-MM-DDThh:mm:ss' format
// - if twoDateTimeWithZ CustomOption is set, will append an ending 'Z'
// - append nothing if Value=0
// - if WithMS is TRUE, will append '.sss' for milliseconds resolution
procedure AddDateTime(const Value: TDateTime; WithMS: boolean=false); overload;
/// append a TDateTime value, expanded as Iso-8601 text with milliseconds
// and Time Zone designator
// - twoDateTimeWithZ CustomOption is ignored in favor of the TZD parameter
// - i.e. 'YYYY-MM-DDThh:mm:ss.sssZ' format
// - TZD is the ending time zone designator ('', 'Z' or '+hh:mm' or '-hh:mm')
procedure AddDateTimeMS(const Value: TDateTime; Expanded: boolean=true;
FirstTimeChar: AnsiChar = 'T'; const TZD: RawUTF8='Z');
/// append an Unsigned 32-bit Integer Value as a String
procedure AddU(Value: cardinal);
/// append an Unsigned 64-bit Integer Value as a String
procedure AddQ(Value: QWord);
/// append an Unsigned 64-bit Integer Value as a quoted hexadecimal String
procedure AddQHex(Value: Qword); {$ifdef HASINLINE}inline;{$endif}
/// append a GUID value, encoded as text without any {}
// - will store e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301'
procedure Add({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID); overload;
/// append a floating-point Value as a String
// - write "Infinity", "-Infinity", and "NaN" for corresponding IEEE values
// - noexp=true will call ExtendedToShortNoExp() to avoid any scientific
// notation in the resulting text
procedure AddDouble(Value: double; noexp: boolean=false); {$ifdef HASINLINE}inline;{$endif}
/// append a floating-point Value as a String
// - write "Infinity", "-Infinity", and "NaN" for corresponding IEEE values
// - noexp=true will call ExtendedToShortNoExp() to avoid any scientific
// notation in the resulting text
procedure AddSingle(Value: single; noexp: boolean=false); {$ifdef HASINLINE}inline;{$endif}
/// append a floating-point Value as a String
// - write "Infinity", "-Infinity", and "NaN" for corresponding IEEE values
// - noexp=true will call ExtendedToShortNoExp() to avoid any scientific
// notation in the resulting text
procedure Add(Value: Extended; precision: integer; noexp: boolean=false); overload;
/// append a floating-point text buffer
// - will correct on the fly '.5' -> '0.5' and '-.5' -> '-0.5'
// - will end not only on #0 but on any char not matching 1[.2[e[-]3]] pattern
// - is used when the input comes from a third-party source with no regular
// output, e.g. a database driver
procedure AddFloatStr(P: PUTF8Char);
/// append strings or integers with a specified format
// - % = #37 marks a string, integer, floating-point, or class parameter
// to be appended as text (e.g. class name)
// - if StringEscape is false (by default), the text won't be escaped before
// adding; but if set to true text will be JSON escaped at writing
// - note that due to a limitation of the "array of const" format, cardinal
// values should be type-casted to Int64() - otherwise the integer mapped
// value will be transmitted, therefore wrongly
{$ifdef OLDTEXTWRITERFORMAT}
// - $ dollar = #36 indicates an integer to be written with 2 digits and a comma
// - | vertical = #124 will write the next char e.g. Add('%|$',[10]) will write '10$'
// - pound = #163 indicates an integer to be written with 4 digits and a comma
// - micro = #181 indicates an integer to be written with 3 digits without any comma
// - currency = #164 indicates CR+LF chars
// - section = #167 indicates to trim last comma
// - since some of this characters above are > #127, they are not UTF-8
// ready, so we expect the input format to be WinAnsi, i.e. mostly English
// text (with chars < #128) with some values to be inserted inside
{$endif}
procedure Add(const Format: RawUTF8; const Values: array of const;
Escape: TTextWriterKind=twNone; WriteObjectOptions: TTextWriterWriteObjectOptions=[woFullExpand]); overload;
/// append some values at once
// - text values (e.g. RawUTF8) will be escaped as JSON
procedure Add(const Values: array of const); overload;
/// append CR+LF (#13#10) chars
// - this method won't call EchoAdd() registered events - use AddEndOfLine()
// method instead
// - AddEndOfLine() will append either CR+LF (#13#10) or LF (#10) depending
// on a flag
procedure AddCR;
/// append CR+LF (#13#10) chars and #9 indentation
// - indentation depth is defined by fHumanReadableLevel protected field
procedure AddCRAndIndent;
/// write the same character multiple times
procedure AddChars(aChar: AnsiChar; aCount: integer);
/// append an Integer Value as a 2 digits String with comma
procedure Add2(Value: PtrUInt);
/// append the current UTC date and time, in our log-friendly format
// - e.g. append '20110325 19241502' - with no trailing space nor tab
// - you may set LocalTime=TRUE to write the local date and time instead
// - this method is very fast, and avoid most calculation or API calls
procedure AddCurrentLogTime(LocalTime: boolean);
/// append the current UTC date and time, in our log-friendly format
// - e.g. append '19/Feb/2019:06:18:55 ' - including a trailing space
// - you may set LocalTime=TRUE to write the local date and time instead
// - this method is very fast, and avoid most calculation or API calls
procedure AddCurrentNCSALogTime(LocalTime: boolean);
/// append a time period, specified in micro seconds, in 00.000.000 TSynLog format
procedure AddMicroSec(MS: cardinal);
/// append an Integer Value as a 4 digits String with comma
procedure Add4(Value: PtrUInt);
/// append an Integer Value as a 3 digits String without any added comma
procedure Add3(Value: PtrUInt);
/// append a line of text with CR+LF at the end
procedure AddLine(const Text: shortstring);
/// append an UTF-8 String, with no JSON escaping
procedure AddString(const Text: RawUTF8);
/// append several UTF-8 strings
procedure AddStrings(const Text: array of RawUTF8); overload;
/// append an UTF-8 string several times
procedure AddStrings(const Text: RawUTF8; count: integer); overload;
/// append a ShortString
procedure AddShort(const Text: ShortString);
/// append a sub-part of an UTF-8 String
// - emulates AddString(copy(Text,start,len))
procedure AddStringCopy(const Text: RawUTF8; start,len: PtrInt);
/// append after trim first lowercase chars ('otDone' will add 'Done' e.g.)
procedure AddTrimLeftLowerCase(Text: PShortString);
/// append a UTF-8 String excluding any space or control char
// - this won't escape the text as expected by JSON
procedure AddTrimSpaces(const Text: RawUTF8); overload;
{$ifdef HASINLINE}inline;{$endif}
/// append a UTF-8 String excluding any space or control char
// - this won't escape the text as expected by JSON
procedure AddTrimSpaces(P: PUTF8Char); overload;
/// append a property name, as '"PropName":'
// - PropName content should not need to be JSON escaped (e.g. no " within,
// and only ASCII 7-bit characters)
// - if twoForceJSONExtended is defined in CustomOptions, it would append
// 'PropName:' without the double quotes
procedure AddProp(PropName: PUTF8Char; PropNameLen: PtrInt);
/// append a ShortString property name, as '"PropName":'
// - PropName content should not need to be JSON escaped (e.g. no " within,
// and only ASCII 7-bit characters)
// - if twoForceJSONExtended is defined in CustomOptions, it would append
// 'PropName:' without the double quotes
// - is a wrapper around AddProp()
procedure AddPropName(const PropName: ShortString);
{$ifdef HASINLINE}inline;{$endif}
/// append a JSON field name, followed by an escaped UTF-8 JSON String and
// a comma (',')
procedure AddPropJSONString(const PropName: shortstring; const Text: RawUTF8);
/// append a JSON field name, followed by a number value and a comma (',')
procedure AddPropJSONInt64(const PropName: shortstring; Value: Int64);
/// append a RawUTF8 property name, as '"FieldName":'
// - FieldName content should not need to be JSON escaped (e.g. no " within)
// - if twoForceJSONExtended is defined in CustomOptions, it would append
// 'PropName:' without the double quotes
// - is a wrapper around AddProp()
procedure AddFieldName(const FieldName: RawUTF8);
{$ifdef HASINLINE}inline;{$endif}
/// append the class name of an Object instance as text
// - aClass must be not nil
procedure AddClassName(aClass: TClass);
/// append an Instance name and pointer, as '"TObjectList(00425E68)"'+SepChar
// - Instance must be not nil
procedure AddInstanceName(Instance: TObject; SepChar: AnsiChar);
/// append an Instance name and pointer, as 'TObjectList(00425E68)'+SepChar
// - Instance must be not nil
// - overriden version in TJSONSerializer would implement IncludeUnitName
procedure AddInstancePointer(Instance: TObject; SepChar: AnsiChar;
IncludeUnitName, IncludePointer: boolean); virtual;
/// append a quoted string as JSON, with in-place decoding
// - if QuotedString does not start with ' or ", it will written directly
// (i.e. expects to be a number, or null/true/false constants)
// - as used e.g. by TJSONObjectDecoder.EncodeAsJSON method and
// JSONEncodeNameSQLValue() function
procedure AddQuotedStringAsJSON(const QuotedString: RawUTF8);
/// append an array of integers as CSV
procedure AddCSVInteger(const Integers: array of Integer); overload;
/// append an array of doubles as CSV
procedure AddCSVDouble(const Doubles: array of double); overload;
/// append an array of RawUTF8 as CSV of JSON strings
procedure AddCSVUTF8(const Values: array of RawUTF8); overload;
/// append an array of const as CSV of JSON values
procedure AddCSVConst(const Values: array of const);
/// write some data Base64 encoded
// - if withMagic is TRUE, will write as '"\uFFF0base64encodedbinary"'
procedure WrBase64(P: PAnsiChar; Len: PtrUInt; withMagic: boolean);
/// write some record content as binary, Base64 encoded with our magic prefix
procedure WrRecord(const Rec; TypeInfo: pointer);
/// write some #0 ended UTF-8 text, according to the specified format
// - if Escape is a constant, consider calling directly AddNoJSONEscape,
// AddJSONEscape or AddOnSameLine methods
procedure Add(P: PUTF8Char; Escape: TTextWriterKind); overload;
/// write some #0 ended UTF-8 text, according to the specified format
// - if Escape is a constant, consider calling directly AddNoJSONEscape,
// AddJSONEscape or AddOnSameLine methods
procedure Add(P: PUTF8Char; Len: PtrInt; Escape: TTextWriterKind); overload;
/// write some #0 ended Unicode text as UTF-8, according to the specified format
// - if Escape is a constant, consider calling directly AddNoJSONEscapeW,
// AddJSONEscapeW or AddOnSameLineW methods
procedure AddW(P: PWord; Len: PtrInt; Escape: TTextWriterKind);
/// append some UTF-8 encoded chars to the buffer, from the main AnsiString type
// - use the current system code page for AnsiString parameter
procedure AddAnsiString(const s: AnsiString; Escape: TTextWriterKind); overload;
/// append some UTF-8 encoded chars to the buffer, from any AnsiString value
// - if CodePage is left to its default value of -1, it will assume
// CurrentAnsiConvert.CodePage prior to Delphi 2009, but newer UNICODE
// versions of Delphi will retrieve the code page from string
// - if CodePage is defined to a >= 0 value, the encoding will take place
procedure AddAnyAnsiString(const s: RawByteString; Escape: TTextWriterKind;
CodePage: Integer=-1);
/// append some UTF-8 encoded chars to the buffer, from any Ansi buffer
// - the codepage should be specified, e.g. CP_UTF8, CP_RAWBYTESTRING,
// CODEPAGE_US, or any version supported by the Operating System
// - if codepage is 0, the current CurrentAnsiConvert.CodePage would be used
// - will use TSynAnsiConvert to perform the conversion to UTF-8
procedure AddAnyAnsiBuffer(P: PAnsiChar; Len: PtrInt;
Escape: TTextWriterKind; CodePage: Integer);
/// append some UTF-8 chars to the buffer
// - input length is calculated from zero-ended char
// - don't escapes chars according to the JSON RFC
procedure AddNoJSONEscape(P: Pointer); overload;
/// append some UTF-8 chars to the buffer
// - don't escapes chars according to the JSON RFC
procedure AddNoJSONEscape(P: Pointer; Len: PtrInt); overload;
/// append some UTF-8 chars to the buffer
// - don't escapes chars according to the JSON RFC
procedure AddNoJSONEscapeUTF8(const text: RawByteString);
{$ifdef HASINLINE}inline;{$endif}
/// flush a supplied TTextWriter, and write pending data as JSON escaped text
// - may be used with InternalJSONWriter, as a faster alternative to
// ! AddNoJSONEscapeUTF8(Source.Text);
procedure AddNoJSONEscape(Source: TTextWriter); overload;
/// append some UTF-8 chars to the buffer
// - if supplied json is '', will write 'null'
procedure AddRawJSON(const json: RawJSON);
/// append some UTF-8 text, quoting all " chars
// - same algorithm than AddString(QuotedStr()) - without memory allocation,
// and with an optional maximum text length (truncated with ending '...')
// - this function implements what is specified in the official SQLite3
// documentation: "A string constant is formed by enclosing the string in single
// quotes ('). A single quote within the string can be encoded by putting two
// single quotes in a row - as in Pascal."
procedure AddQuotedStr(Text: PUTF8Char; Quote: AnsiChar; TextMaxLen: PtrInt=0);
/// append some chars, escaping all HTML special chars as expected
procedure AddHtmlEscape(Text: PUTF8Char; Fmt: TTextWriterHTMLFormat=hfAnyWhere); overload;
/// append some chars, escaping all HTML special chars as expected
procedure AddHtmlEscape(Text: PUTF8Char; TextLen: PtrInt;
Fmt: TTextWriterHTMLFormat=hfAnyWhere); overload;
/// append some chars, escaping all HTML special chars as expected
procedure AddHtmlEscapeString(const Text: string;
Fmt: TTextWriterHTMLFormat=hfAnyWhere);
/// append some chars, escaping all HTML special chars as expected
procedure AddHtmlEscapeUTF8(const Text: RawUTF8;
Fmt: TTextWriterHTMLFormat=hfAnyWhere);
/// append some chars, escaping all XML special chars as expected
// - i.e. < > & " ' as &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 serialize it
// in big-endian order (most-significant byte first), as used by humans
// - up to the internal buffer bytes may be converted
procedure AddBinToHexDisplay(Bin: pointer; BinBytes: integer);
/// fast conversion from binary data into MSB hexa chars
// - up to the internal buffer bytes may be converted
procedure AddBinToHexDisplayLower(Bin: pointer; BinBytes: integer);
/// fast conversion from binary data into quoted MSB lowercase hexa chars
// - up to the internal buffer bytes may be converted
procedure AddBinToHexDisplayQuoted(Bin: pointer; BinBytes: integer);
/// append a Value as significant hexadecimal text
// - append its minimal size, i.e. excluding highest bytes containing 0
// - use GetNextItemHexa() to decode such a text value
procedure AddBinToHexDisplayMinChars(Bin: pointer; BinBytes: PtrInt);
/// add the pointer into significant hexa chars, ready to be displayed
procedure AddPointer(P: PtrUInt); {$ifdef HASINLINE}inline;{$endif}
/// write a byte as hexa chars
procedure AddByteToHex(Value: byte);
/// write a Int18 value (0..262143) as 3 chars
// - this encoding is faster than Base64, and has spaces on the left side
// - use function Chars3ToInt18() to decode the textual content
procedure AddInt18ToChars3(Value: cardinal);
/// append some unicode chars to the buffer
// - WideCharCount is the unicode chars count, not the byte size
// - don't escapes chars according to the JSON RFC
// - will convert the Unicode chars into UTF-8
procedure AddNoJSONEscapeW(WideChar: PWord; WideCharCount: integer);
/// append some UTF-8 encoded chars to the buffer
// - escapes chars according to the JSON RFC
// - if Len is 0, writing will stop at #0 (default Len=0 is slightly faster
// than specifying Len>0 if you are sure P is zero-ended - e.g. from RawUTF8)
procedure AddJSONEscape(P: Pointer; Len: PtrInt=0); overload;
/// append some UTF-8 encoded chars to the buffer, from a generic string type
// - faster than AddJSONEscape(pointer(StringToUTF8(string))
// - escapes chars according to the JSON RFC
procedure AddJSONEscapeString(const s: string); {$ifdef HASINLINE}inline;{$endif}
/// append some UTF-8 encoded chars to the buffer, from the main AnsiString type
// - escapes chars according to the JSON RFC
procedure AddJSONEscapeAnsiString(const s: AnsiString);
/// append some UTF-8 encoded chars to the buffer, from a generic string type
// - faster than AddNoJSONEscape(pointer(StringToUTF8(string))
// - don't escapes chars according to the JSON RFC
// - will convert the Unicode chars into UTF-8
procedure AddNoJSONEscapeString(const s: string); {$ifdef UNICODE}inline;{$endif}
/// append some Unicode encoded chars to the buffer
// - if Len is 0, Len is calculated from zero-ended widechar
// - escapes chars according to the JSON RFC
procedure AddJSONEscapeW(P: PWord; Len: PtrInt=0);
/// append an open array constant value to the buffer
// - "" will be added if necessary
// - escapes chars according to the JSON RFC
// - very fast (avoid most temporary storage)
procedure AddJSONEscape(const V: TVarRec); overload;
/// flush a supplied TTextWriter, and write pending data as JSON escaped text
// - may be used with InternalJSONWriter, as a faster alternative to
// ! AddJSONEscape(Pointer(fInternalJSONWriter.Text),0);
procedure AddJSONEscape(Source: TTextWriter); overload;
/// append a UTF-8 JSON String, between double quotes and with JSON escaping
procedure AddJSONString(const Text: RawUTF8);
/// append an open array constant value to the buffer
// - "" won't be added for string values
// - string values may be escaped, depending on the supplied parameter
// - very fast (avoid most temporary storage)
procedure Add(const V: TVarRec; Escape: TTextWriterKind=twNone;
WriteObjectOptions: TTextWriterWriteObjectOptions=[woFullExpand]); overload;
/// encode the supplied data as an UTF-8 valid JSON object content
// - data must be supplied two by two, as Name,Value pairs, e.g.
// ! aWriter.AddJSONEscape(['name','John','year',1972]);
// will append to the buffer:
// ! '{"name":"John","year":1972}'
// - or you can specify nested arrays or objects with '['..']' or '{'..'}':
// ! aWriter.AddJSONEscape(['doc','{','name','John','ab','[','a','b']','}','id',123]);
// will append to the buffer:
// ! '{"doc":{"name":"John","abc":["a","b"]},"id":123}'
// - note that, due to a Delphi compiler limitation, cardinal values should be
// type-casted to Int64() (otherwise the integer mapped value will be converted)
// - you can pass nil as parameter for a null JSON value
procedure AddJSONEscape(const NameValuePairs: array of const); overload;
{$ifndef NOVARIANTS}
/// encode the supplied (extended) JSON content, with parameters,
// as an UTF-8 valid JSON object content
// - in addition to the JSON RFC specification strict mode, this method will
// handle some BSON-like extensions, e.g. unquoted field names:
// ! aWriter.AddJSON('{id:?,%:{name:?,birthyear:?}}',['doc'],[10,'John',1982]);
// - you can use nested _Obj() / _Arr() instances
// ! aWriter.AddJSON('{%:{$in:[?,?]}}',['type'],['food','snack']);
// ! aWriter.AddJSON('{type:{$in:?}}',[],[_Arr(['food','snack'])]);
// ! // which are the same as:
// ! aWriter.AddShort('{"type":{"$in":["food","snack"]}}');
// - if the SynMongoDB unit is used in the application, the MongoDB Shell
// syntax will also be recognized to create TBSONVariant, like
// ! new Date() ObjectId() MinKey MaxKey /<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(var aDynArray: TDynArray); overload;
/// append a dynamic array content as UTF-8 encoded JSON array
// - expect a dynamic array TDynArrayHashed wrapper as incoming parameter
procedure AddDynArrayJSON(var aDynArray: TDynArrayHashed); overload;
{$ifdef HASINLINE}inline;{$endif}
/// append a dynamic array content as UTF-8 encoded JSON array
// - just a wrapper around the other overloaded method, creating a
// temporary TDynArray wrapper on the stack
// - to be used e.g. for custom record JSON serialization, within a
// TDynArrayJSONCustomWriter callback
procedure AddDynArrayJSON(aTypeInfo: pointer; const aValue); overload;
/// same as AddDynArrayJSON(), but will double all internal " and bound with "
// - this implementation will avoid most memory allocations
procedure AddDynArrayJSONAsString(aTypeInfo: pointer; var aValue);
/// append a T*ObjArray dynamic array as a JSON array
// - as expected by TJSONSerializer.RegisterObjArrayForJSON()
procedure AddObjArrayJSON(const aObjArray;
aOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]);
/// append a record content as UTF-8 encoded JSON or custom serialization
// - default serialization will use Base64 encoded binary stream, or
// a custom serialization, in case of a previous registration via
// RegisterCustomJSONSerializer() class method - from a dynamic array
// handling this kind of records, or directly from TypeInfo() of the record
// - by default, custom serializers defined via RegisterCustomJSONSerializer()
// would write enumerates and sets as integer numbers, unless
// twoEnumSetsAsTextInRecord or twoEnumSetsAsBooleanInRecord is set in
// the instance CustomOptions
procedure AddRecordJSON(const Rec; TypeInfo: pointer);
{$ifndef NOVARIANTS}
/// append a variant content as number or string
// - default Escape=twJSONEscape will create valid JSON content, which
// can be converted back to a variant value using VariantLoadJSON()
// - default JSON serialization options would apply, unless
// twoForceJSONExtended or twoForceJSONStandard is defined
// - note that before Delphi 2009, any varString value is expected to be
// a RawUTF8 instance - which does make sense in the mORMot context
procedure AddVariant(const Value: variant; Escape: TTextWriterKind=twJSONEscape);
{$endif}
/// append a void record content as UTF-8 encoded JSON or custom serialization
// - this method will first create a void record (i.e. filled with #0 bytes)
// then save its content with default or custom serialization
procedure AddVoidRecordJSON(TypeInfo: pointer);
/// append a JSON value from its RTTI type
// - handle tkClass,tkEnumeration,tkSet,tkRecord,tkDynArray,tkVariant types
// - write null for other types
procedure AddTypedJSON(aTypeInfo: pointer; const aValue);
/// serialize as JSON the given object
// - this default implementation will write null, or only write the
// class name and pointer if FullExpand is true - use
// TJSONSerializer.WriteObject method for full RTTI handling
// - default implementation will write TList/TCollection/TStrings/TRawUTF8List
// as appropriate array of class name/pointer (if woFullExpand is set)
procedure WriteObject(Value: TObject;
Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]); virtual;
/// same as WriteObject(), but will double all internal " and bound with "
// - this implementation will avoid most memory allocations
procedure WriteObjectAsString(Value: TObject;
Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]);
/// append a JSON value, array or document as simple XML content
// - you can use JSONBufferToXML() and JSONToXML() functions as wrappers
// - this method is called recursively to handle all kind of JSON values
// - WARNING: the JSON buffer is decoded in-place, so will be changed
// - returns the end of the current JSON converted level, or nil if the
// supplied content was not correct JSON
function AddJSONToXML(JSON: PUTF8Char; ArrayName: PUTF8Char=nil;
EndOfObject: PUTF8Char=nil): PUTF8Char;
/// append a JSON value, array or document, in a specified format
// - will parse the JSON buffer and write its content with proper line
// feeds and indentation, according to the supplied TTextWriterJSONFormat
// - see also JSONReformat() and JSONBufferReformat() wrappers
// - this method is called recursively to handle all kind of JSON values
// - WARNING: the JSON buffer is decoded in-place, so will be changed
// - returns the end of the current JSON converted level, or nil if the
// supplied content was not valid JSON
function AddJSONReformat(JSON: PUTF8Char; Format: TTextWriterJSONFormat;
EndOfObject: PUTF8Char): PUTF8Char;
/// define a custom serialization for a given dynamic array or record
// - expects TypeInfo() from a dynamic array or a record (will raise an
// exception otherwise)
// - for a dynamic array, the associated item record RTTI will be registered
// - for a record, any matching dynamic array will also be registered
// - by default, TIntegerDynArray and such known classes are processed as
// true JSON arrays: but you can specify here some callbacks to perform
// the serialization process for any kind of dynamic array
// - any previous registration is overridden
// - setting both aReader=aWriter=nil will return back to the default
// binary + Base64 encoding serialization (i.e. undefine custom serializer)
class procedure RegisterCustomJSONSerializer(aTypeInfo: pointer;
aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter);
{$ifndef NOVARIANTS}
/// define a custom serialization for a given variant custom type
// - used e.g. to serialize TBCD values
class procedure RegisterCustomJSONSerializerForVariant(aClass: TCustomVariantType;
aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter);
/// define a custom serialization for a given variant custom type
// - used e.g. to serialize TBCD values
class procedure RegisterCustomJSONSerializerForVariantByType(aVarType: TVarType;
aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter);
{$endif NOVARIANTS}
/// define a custom serialization for a given dynamic array or record
// - the RTTI information will here be defined as plain text
// - since Delphi 2010, you can call directly
// RegisterCustomJSONSerializerFromTextSimpleType()
// - aTypeInfo may be valid TypeInfo(), or any fixed pointer value if the
// record does not have any RTTI (e.g. a record without any nested reference-
// counted types)
// - the record where the data will be stored should be defined as PACKED:
// ! type TMyRecord = packed record
// ! A,B,C: integer;
// ! D: RawUTF8;
// ! E: record; // or array of record/integer/string/...
// ! E1,E2: double;
// ! end;
// ! end;
// - call this method with aRTTIDefinition='' to return back to the default
// binary + Base64 encoding serialization (i.e. undefine custom serializer)
// - only known sub types are byte, word, integer, cardinal, Int64, single,
// double, currency, TDateTime, TTimeLog, RawUTF8, String, WideString,
// SynUnicode, TGUID (encoded via GUIDToText) or a nested record or dynamic
// array of the same simple types or record
// - RTTI textual information shall be supplied as text, with the
// same format as with a pascal record:
// ! 'A,B,C: integer; D: RawUTF8; E: record E1,E2: double;'
// ! 'A,B,C: integer; D: RawUTF8; E: array of record E1,E2: double;'
// ! 'A,B,C: integer; D: RawUTF8; E: array of SynUnicode; F: array of TGUID'
// or a shorter alternative syntax for records and arrays:
// ! 'A,B,C: integer; D: RawUTF8; E: {E1,E2: double}'
// ! 'A,B,C: integer; D: RawUTF8; E: [E1,E2: double]'
// in fact ; could be ignored:
// ! 'A,B,C:integer D:RawUTF8 E:{E1,E2:double}'
// ! 'A,B,C:integer D:RawUTF8 E:[E1,E2:double]'
// or even : could be ignored:
// ! 'A,B,C integer D RawUTF8 E{E1,E2 double}'
// ! 'A,B,C integer D RawUTF8 E[E1,E2 double]'
// - it will return the cached TJSONRecordTextDefinition
// instance corresponding to the supplied RTTI text definition
class function RegisterCustomJSONSerializerFromText(aTypeInfo: pointer;
const aRTTIDefinition: RawUTF8): TJSONRecordAbstract; overload;
/// define a custom serialization for several dynamic arrays or records
// - the TypeInfo() and textual RTTI information will here be defined as
// ([TypeInfo(TType1),_TType1,TypeInfo(TType2),_TType2]) pairs
// - a wrapper around the overloaded RegisterCustomJSONSerializerFromText()
class procedure RegisterCustomJSONSerializerFromText(
const aTypeInfoTextDefinitionPairs: array of const); overload;
/// change options for custom serialization of dynamic array or record
// - will return TRUE if the options have been changed, FALSE if the
// supplied type info was not previously registered
// - if AddIfNotExisting is TRUE, and enhanced RTTI is available (since
// Delphi 2010), you would be able to customize the options of this type
class function RegisterCustomJSONSerializerSetOptions(aTypeInfo: pointer;
aOptions: TJSONCustomParserSerializationOptions;
aAddIfNotExisting: boolean=false): boolean; overload;
/// change options for custom serialization of dynamic arrays or records
// - will return TRUE if the options have been changed, FALSE if the
// supplied type info was not previously registered for at least one type
// - if AddIfNotExisting is TRUE, and enhanced RTTI is available (since
// Delphi 2010), you would be able to customize the options of this type
class function RegisterCustomJSONSerializerSetOptions(
const aTypeInfo: array of pointer; aOptions: TJSONCustomParserSerializationOptions;
aAddIfNotExisting: boolean=false): boolean; overload;
/// retrieve a previously registered custom parser instance from its type
// - will return nil if the type info was not available, or defined just
// with some callbacks
// - if AddIfNotExisting is TRUE, and enhanced RTTI is available (since
// Delphi 2010), you would be able to retrieve this type's parser even
// if the record type has not been previously used
class function RegisterCustomJSONSerializerFindParser(
aTypeInfo: pointer; aAddIfNotExisting: boolean=false): TJSONRecordAbstract;
/// define a custom serialization for a given simple type
// - you should be able to use this type in the RTTI text definition
// of any further RegisterCustomJSONSerializerFromText() call
// - the RTTI information should be enough to serialize the type from
// its name (e.g. an enumeration for older Delphi revision, but all records
// since Delphi 2010)
// - you can supply a custom type name, which will be registered in addition
// to the "official" name defined at RTTI level
// - on older Delphi versions (up to Delphi 2009), it will handle only
// enumerations, which will be transmitted as JSON string instead of numbers
// - since Delphi 2010, any record type can be supplied - which is more
// convenient than calling RegisterCustomJSONSerializerFromText()
class procedure RegisterCustomJSONSerializerFromTextSimpleType(aTypeInfo: pointer;
const aTypeName: RawUTF8=''); overload;
/// define a custom binary serialization for a given simple type
// - you should be able to use this type in the RTTI text definition
// of any further RegisterCustomJSONSerializerFromText() call
// - data will be serialized as BinToHexDisplayLower() JSON hexadecimal string
// - you can truncate the original data size (e.g. if all bits of an integer
// are not used) by specifying the aFieldSize optional parameter
class procedure RegisterCustomJSONSerializerFromTextBinaryType(aTypeInfo: pointer;
aDataSize: integer; aFieldSize: integer=0); overload;
/// define custom binary serialization for several simple types
// - data will be serialized as BinToHexDisplayLower() JSON hexadecimal string
// - the TypeInfo() and associated size information will here be defined as triplets:
// ([TypeInfo(TType1),SizeOf(TType1),TYPE1_BYTES,TypeInfo(TType2),SizeOf(TType2),TYPE2_BYTES])
// - a wrapper around the overloaded RegisterCustomJSONSerializerFromTextBinaryType()
class procedure RegisterCustomJSONSerializerFromTextBinaryType(
const aTypeInfoDataFieldSize: array of const); overload;
/// define a custom serialization for several simple types
// - will call the overloaded RegisterCustomJSONSerializerFromTextSimpleType
// method for each supplied type information
class procedure RegisterCustomJSONSerializerFromTextSimpleType(
const aTypeInfos: array of pointer); overload;
/// undefine a custom serialization for a given dynamic array or record
// - it will un-register any callback or text-based custom serialization
// i.e. any previous RegisterCustomJSONSerializer() or
// RegisterCustomJSONSerializerFromText() call
// - expects TypeInfo() from a dynamic array or a record (will raise an
// exception otherwise)
// - it will set back to the default binary + Base64 encoding serialization
class procedure UnRegisterCustomJSONSerializer(aTypeInfo: pointer);
/// retrieve low-level custom serialization callbaks for a dynamic array
// - returns TRUE if this array has a custom JSON parser, and set the
// corresponding serialization/unserialization callbacks
class function GetCustomJSONParser(var DynArray: TDynArray;
out CustomReader: TDynArrayJSONCustomReader;
out CustomWriter: TDynArrayJSONCustomWriter): boolean;
/// append some chars to the buffer in one line
// - P should be ended with a #0
// - will write #1..#31 chars as spaces (so content will stay on the same line)
procedure AddOnSameLine(P: PUTF8Char); overload;
/// append some chars to the buffer in one line
// - will write #0..#31 chars as spaces (so content will stay on the same line)
procedure AddOnSameLine(P: PUTF8Char; Len: PtrInt); overload;
/// append some wide chars to the buffer in one line
// - will write #0..#31 chars as spaces (so content will stay on the same line)
procedure AddOnSameLineW(P: PWord; Len: PtrInt);
/// return the last char appended
// - returns #0 if no char has been written yet
function LastChar: AnsiChar;
/// how many bytes are currently in the internal buffer and not on disk
// - see TextLength for the total number of bytes, on both disk and memory
function PendingBytes: PtrUInt;
{$ifdef HASINLINE}inline;{$endif}
/// how many bytes were currently written on disk
// - excluding the bytes in the internal buffer
// - see TextLength for the total number of bytes, on both disk and memory
property WrittenBytes: PtrUInt read fTotalFileSize;
/// low-level access to the current indentation level
property HumanReadableLevel: integer read fHumanReadableLevel write fHumanReadableLevel;
/// the last char appended is canceled
// - only one char cancelation is allowed at the same position: don't call
// CancelLastChar/CancelLastComma more than once without appending text inbetween
procedure CancelLastChar; overload; {$ifdef HASINLINE}inline;{$endif}
/// the last char appended is canceled, if match the supplied one
// - only one char cancelation is allowed at the same position: don't call
// CancelLastChar/CancelLastComma more than once without appending text inbetween
procedure CancelLastChar(aCharToCancel: AnsiChar); overload; {$ifdef HASINLINE}inline;{$endif}
/// the last char appended is canceled if it was a ','
// - only one char cancelation is allowed at the same position: don't call
// CancelLastChar/CancelLastComma more than once without appending text inbetween
procedure CancelLastComma; {$ifdef HASINLINE}inline;{$endif}
/// rewind the Stream to the position when Create() was called
// - note that this does not clear the Stream content itself, just
// move back its writing position to its initial place
procedure CancelAll;
/// count of added bytes to the stream
// - see PendingBytes for the number of bytes currently in the memory buffer
// or WrittenBytes for the number of bytes already written to disk
property TextLength: PtrUInt read GetTextLength;
/// optional event called before FlushToStream method process
property OnFlushToStream: TOnTextWriterFlush read fOnFlushToStream write fOnFlushToStream;
/// allows to override default WriteObject property JSON serialization
property OnWriteObject: TOnTextWriterObjectProp read fOnWriteObject write fOnWriteObject;
/// the internal TStream used for storage
// - you should call the FlushFinal (or FlushToStream) methods before using
// this TStream content, to flush all pending characters
// - if the TStream instance has not been specified when calling the
// TTextWriter constructor, it can be forced via this property, before
// any writting
property Stream: TStream read fStream write SetStream;
/// global options to customize this TTextWriter instance process
// - allows to override e.g. AddRecordJSON() and AddDynArrayJSON() behavior
property CustomOptions: TTextWriterOptions read fCustomOptions write fCustomOptions;
end;
/// class of our simple TEXT format writer to a Stream, with echoing
// - as used by TSynLog for writing its content
// - see TTextWriterWithEcho.SetAsDefaultJSONClass
TTextWriterClass = class of TTextWriterWithEcho;
/// Stream TEXT writer, with optional echoing of the lines
// - as used e.g. by TSynLog writer for log optional redirection
// - is defined as a sub-class to reduce plain TTextWriter scope
// - see SynTable.pas for SQL resultset export via TJSONWriter
// - see mORMot.pas for proper class serialization via TJSONSerializer.WriteObject
TTextWriterWithEcho = class(TTextWriter)
protected
fEchoStart: PtrInt;
fEchoBuf: RawUTF8;
fEchos: array of TOnTextWriterEcho;
function EchoFlush: PtrInt;
function GetEndOfLineCRLF: boolean; {$ifdef HASINLINE}inline;{$endif}
procedure SetEndOfLineCRLF(aEndOfLineCRLF: boolean);
public
/// write pending data to the Stream, with automatic buffer resizal and echoing
// - this overriden method will handle proper echoing
procedure FlushToStream; override;
/// mark an end of line, ready to be "echoed" to registered listeners
// - append a LF (#10) char or CR+LF (#13#10) chars to the buffer, depending
// on the EndOfLineCRLF property value (default is LF, to minimize storage)
// - any callback registered via EchoAdd() will monitor this line
// - used e.g. by TSynLog for console output, as stated by Level parameter
procedure AddEndOfLine(aLevel: TSynLogInfo=sllNone);
/// add a callback to echo each line written by this class
// - this class expects AddEndOfLine to mark the end of each line
procedure EchoAdd(const aEcho: TOnTextWriterEcho);
/// remove a callback to echo each line written by this class
// - event should have been previously registered by a EchoAdd() call
procedure EchoRemove(const aEcho: TOnTextWriterEcho);
/// reset the internal buffer used for echoing content
procedure EchoReset;
/// define how AddEndOfLine method stores its line feed characters
// - by default (FALSE), it will append a LF (#10) char to the buffer
// - you can set this property to TRUE, so that CR+LF (#13#10) chars will
// be appended instead
// - is just a wrapper around twoEndOfLineCRLF item in CustomOptions
property EndOfLineCRLF: boolean read GetEndOfLineCRLF write SetEndOfLineCRLF;
end;
var
/// contains the default JSON serialization class for WriteObject
// - if only SynCommons.pas is used, it will be TTextWriterWithEcho
// - mORMot.pas will assign TJSONSerializer which uses RTTI to serialize
// TSQLRecord and any class published properties as JSON
DefaultTextWriterSerializer: TTextWriterClass = TTextWriterWithEcho;
/// recognize a simple type from a supplied type information
// - first try by name via TJSONCustomParserRTTI.TypeNameToSimpleRTTIType,
// then from RTTI via TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType
// - will return ptCustom for any unknown type
function TypeInfoToRttiType(aTypeInfo: pointer): TJSONCustomParserRTTIType;
/// serialize most kind of content as JSON, using its RTTI
// - is just a wrapper around TTextWriter.AddTypedJSON()
// - so would handle tkClass, tkEnumeration, tkSet, tkRecord, tkDynArray,
// tkVariant kind of content - other kinds would return 'null'
// - you can override serialization options if needed
procedure SaveJSON(const Value; TypeInfo: pointer;
Options: TTextWriterOptions; var result: RawUTF8); overload;
/// serialize most kind of content as JSON, using its RTTI
// - is just a wrapper around TTextWriter.AddTypedJSON()
// - so would handle tkClass, tkEnumeration, tkSet, tkRecord, tkDynArray,
// tkVariant kind of content - other kinds would return 'null'
function SaveJSON(const Value; TypeInfo: pointer;
EnumSetsAsText: boolean=false): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// will serialize any TObject into its UTF-8 JSON representation
/// - serialize as JSON the published integer, Int64, floating point values,
// TDateTime (stored as ISO 8601 text), string, variant and enumerate
// (e.g. boolean) properties of the object (and its parents)
// - would set twoForceJSONStandard to force standard (non-extended) JSON
// - the enumerates properties are stored with their integer index value
// - will write also the properties published in the parent classes
// - nested properties are serialized as nested JSON objects
// - any TCollection property will also be serialized as JSON arrays
// - you can add some custom serializers for ANY Delphi class, via mORMot.pas'
// TJSONSerializer.RegisterCustomSerializer() class method
// - call internaly TJSONSerializer.WriteObject() method (or fallback to
// TJSONWriter if mORMot.pas is not linked to the executable)
function ObjectToJSON(Value: TObject;
Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]): RawUTF8;
/// will serialize set of TObject into its UTF-8 JSON representation
// - follows ObjectToJSON()/TTextWriter.WriterObject() functions output
// - if Names is not supplied, the corresponding class names would be used
function ObjectsToJSON(const Names: array of RawUTF8; const Values: array of TObject;
Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]): RawUTF8;
type
/// abstract ancestor to manage a dynamic array of TObject
// - do not use this abstract class directly, but rather the inherited
// TObjectListHashed and TObjectListPropertyHashed
TObjectListHashedAbstract = class
protected
fList: TObjectDynArray;
fCount: integer;
fHash: TDynArrayHashed;
public
/// initialize the class instance
// - if aFreeItems is TRUE (default), will behave like a TObjectList
// - if aFreeItems is FALSE, will behave like a TList
constructor Create(aFreeItems: boolean=true); reintroduce;
/// release used memory
destructor Destroy; override;
/// search and add an object reference to the list
// - returns the found/added index
function Add(aObject: TObject; out wasAdded: boolean): integer; virtual; abstract;
/// retrieve an object index within the list, using a fast hash table
// - returns -1 if not found
function IndexOf(aObject: TObject): integer; virtual; abstract;
/// delete an object from the list
// - the internal hash table is not recreated, just invalidated
// (i.e. this method calls HashInvalidate not FindHashedAndDelete)
// - will invalide the whole hash table
procedure Delete(aIndex: integer); overload;
/// delete an object from the list
// - will invalide the whole hash table
procedure Delete(aObject: TObject); overload; virtual;
/// direct access to the items list array
property List: TObjectDynArray read fList;
/// returns the count of stored objects
property Count: integer read fCount;
/// direct access to the underlying hashing engine
property Hash: TDynArrayHashed read fHash;
end;
/// this class behaves like TList/TObjectList, but will use hashing
// for (much) faster IndexOf() method
TObjectListHashed = class(TObjectListHashedAbstract)
public
/// search and add an object reference to the list
// - returns the found/added index
// - if added, hash is stored and Items[] := aObject
function Add(aObject: TObject; out wasAdded: boolean): integer; override;
/// retrieve an object index within the list, using a fast hash table
// - returns -1 if not found
function IndexOf(aObject: TObject): integer; override;
/// delete an object from the list
// - overriden method won't invalidate the whole hash table, but refresh it
procedure Delete(aObject: TObject); override;
end;
/// function prototype used to retrieve a pointer to the hashed property
// value of a TObjectListPropertyHashed list
TObjectListPropertyHashedAccessProp = function(aObject: TObject): pointer;
/// this class will hash and search for a sub property of the stored objects
TObjectListPropertyHashed = class(TObjectListHashedAbstract)
protected
fSubPropAccess: TObjectListPropertyHashedAccessProp;
function IntHash(const Elem): cardinal;
function IntComp(const A,B): integer;
public
/// initialize the class instance with the corresponding callback in order
// to handle sub-property hashing and search
// - see TSetWeakZeroClass in mORMot.pas unit as example:
// ! function WeakZeroClassSubProp(aObject: TObject): TObject;
// ! begin
// ! result := TSetWeakZeroInstance(aObject).fInstance;
// ! end;
// - by default, aHashElement/aCompare will hash/search for pointers:
// you can specify the hash/search methods according to your sub property
// (e.g. HashAnsiStringI/SortDynArrayAnsiStringI for a RawUTF8)
// - if aFreeItems is TRUE (default), will behave like a TObjectList;
// if aFreeItems is FALSE, will behave like a TList
constructor Create(aSubPropAccess: TObjectListPropertyHashedAccessProp;
aHashElement: TDynArrayHashOne=nil; aCompare: TDynArraySortCompare=nil;
aFreeItems: boolean=true); reintroduce;
/// search and add an object reference to the list
// - returns the found/added index
// - if added, only the hash is stored: caller has to set List[i]
function Add(aObject: TObject; out wasAdded: boolean): integer; override;
/// retrieve an object index within the list, using a fast hash table
// - returns -1 if not found
function IndexOf(aObject: TObject): integer; override;
end;
/// abstract class stored by a TPointerClassHash list
TPointerClassHashed = class
protected
fInfo: pointer;
public
/// initialize the instance
constructor Create(aInfo: pointer);
/// the associated information of this instance
// - may be e.g. a PTypeInfo value, when caching RTTI information
property Info: pointer read fInfo write fInfo;
end;
/// a reference to a TPointerClassHashed instance
PPointerClassHashed = ^TPointerClassHashed;
/// handle a O(1) hashed-based storage of TPointerClassHashed, from a pointer
// - used e.g. to store RTTI information from its PTypeInfo value
// - if not thread safe, but could be used to store RTTI, since all type
// information should have been initialized before actual process
TPointerClassHash = class(TObjectListPropertyHashed)
public
/// initialize the storage list
constructor Create;
/// try to add an entry to the storage
// - returns nil if the supplied information is already in the list
// - returns a pointer to where a newly created TPointerClassHashed
// instance should be stored
// - this method is not thread-safe
function TryAdd(aInfo: pointer): PPointerClassHashed;
/// search for a stored instance, from its supplied pointer reference
// - returns nil if aInfo was not previously added by FindOrAdd()
// - this method is not thread-safe
function Find(aInfo: pointer): TPointerClassHashed;
end;
/// handle a O(1) hashed-based storage of TPointerClassHashed, from a pointer
// - this inherited class add a mutex to be thread-safe
TPointerClassHashLocked = class(TPointerClassHash)
protected
fSafe: TSynLocker;
public
/// initialize the storage list
constructor Create;
/// finalize the storage list
destructor Destroy; override;
/// try to add an entry to the storage
// - returns false if the supplied information is already in the list
// - returns true, and a pointer to where a newly created TPointerClassHashed
// instance should be stored: in this case, you should call UnLock once set
// - could be used as such:
// !var entry: PPointerClassHashed;
// !...
// ! if HashList.TryAddLocked(aTypeInfo,entry) then
// ! try
// ! entry^ := TMyCustomPointerClassHashed.Create(aTypeInfo,...);
// ! finally
// ! HashList.Unlock;
// ! end;
// !...
function TryAddLocked(aInfo: pointer; out aNewEntry: PPointerClassHashed): boolean;
/// release the lock after a previous TryAddLocked()=true call
procedure Unlock;
/// search for a stored instance, from its supplied pointer reference
// - returns nil if aInfo was not previously added by FindOrAdd()
// - this overriden method is thread-safe, unless returned TPointerClassHashed
// instance is deleted in-between
function FindLocked(aInfo: pointer): TPointerClassHashed;
end;
/// add locking methods to a TSynObjectList
// - this class overrides the regular TSynObjectList, and do not share any
// code with the TObjectListHashedAbstract/TObjectListHashed classes
// - you need to call the Safe.Lock/Unlock methods by hand to protect the
// execution of index-oriented methods (like Delete/Items/Count...): the
// list content may change in the background, so using indexes is thread-safe
// - on the other hand, Add/Clear/ClearFromLast/Remove stateless methods have
// been overriden in this class to call Safe.Lock/Unlock, and therefore are
// thread-safe and protected to any background change
TSynObjectListLocked = class(TSynObjectList)
protected
fSafe: TSynLocker;
public
/// initialize the list instance
// - the stored TObject instances will be owned by this TSynObjectListLocked,
// unless AOwnsObjects is set to false
constructor Create(aOwnsObjects: boolean=true); reintroduce;
/// release the list instance (including the locking resource)
destructor Destroy; override;
/// add one item to the list using the global critical section
function Add(item: pointer): integer; override;
/// delete all items of the list using the global critical section
procedure Clear; override;
/// delete all items of the list in reverse order, using the global critical section
procedure ClearFromLast; override;
/// fast delete one item in the list
function Remove(item: pointer): integer; override;
/// check an item using the global critical section
function Exists(item: pointer): boolean; override;
/// the critical section associated to this list instance
// - could be used to protect shared resources within the internal process,
// for index-oriented methods like Delete/Items/Count...
// - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block
property Safe: TSynLocker read fSafe;
end;
/// deprecated class name, for backward compatibility only
TObjectListLocked = TSynObjectListLocked;
/// possible values used by TRawUTF8List.Flags
TRawUTF8ListFlags = set of (
fObjectsOwned, fCaseSensitive, fNoDuplicate, fOnChangeTrigerred);
/// TStringList-class optimized to work with our native UTF-8 string type
// - can optionally store associated some TObject instances
// - high-level methods of this class are thread-safe
// - if fNoDuplicate flag is defined, an internal hash table will be
// maintained to perform IndexOf() lookups in O(1) linear way
TRawUTF8List = class
protected
fCount: PtrInt;
fValue: TRawUTF8DynArray;
fValues: TDynArrayHashed;
fObjects: TObjectDynArray;
fFlags: TRawUTF8ListFlags;
fNameValueSep: AnsiChar;
fOnChange, fOnChangeBackupForBeginUpdate: TNotifyEvent;
fOnChangeLevel: integer;
fSafe: TSynLocker;
function GetCount: PtrInt; {$ifdef HASINLINE}inline;{$endif}
procedure SetCapacity(const capa: PtrInt);
function GetCapacity: PtrInt;
function Get(Index: PtrInt): RawUTF8; {$ifdef HASINLINE}inline;{$endif}
procedure Put(Index: PtrInt; const Value: RawUTF8);
function GetObject(Index: PtrInt): pointer; {$ifdef HASINLINE}inline;{$endif}
procedure PutObject(Index: PtrInt; Value: pointer);
function GetName(Index: PtrInt): RawUTF8;
function GetValue(const Name: RawUTF8): RawUTF8;
procedure SetValue(const Name, Value: RawUTF8);
function GetTextCRLF: RawUTF8;
procedure SetTextCRLF(const Value: RawUTF8);
procedure SetTextPtr(P,PEnd: PUTF8Char; const Delimiter: RawUTF8);
function GetTextPtr: PPUtf8CharArray; {$ifdef HASINLINE}inline;{$endif}
function GetNoDuplicate: boolean; {$ifdef HASINLINE}inline;{$endif}
function GetObjectPtr: PPointerArray; {$ifdef HASINLINE}inline;{$endif}
function GetCaseSensitive: boolean; {$ifdef HASINLINE}inline;{$endif}
procedure SetCaseSensitive(Value: boolean); virtual;
procedure Changed; virtual;
procedure InternalDelete(Index: PtrInt);
procedure OnChangeHidden(Sender: TObject);
public
/// initialize the RawUTF8/Objects storage
// - by default, any associated Objects[] are just weak references;
// you may supply fOwnObjects flag to force object instance management
// - if you want the stored text items to be unique, set fNoDuplicate
// and then an internal hash table will be maintained for fast IndexOf()
// - you can unset fCaseSensitive to let the UTF-8 lookup be case-insensitive
constructor Create(aFlags: TRawUTF8ListFlags=[fCaseSensitive]); overload;
/// backward compatiliby overloaded constructor
// - please rather use the overloaded Create(TRawUTF8ListFlags)
constructor Create(aOwnObjects: boolean; aNoDuplicate: boolean=false;
aCaseSensitive: boolean=true); overload;
/// finalize the internal objects stored
// - if instance was created with fOwnObjects flag
destructor Destroy; override;
/// get a stored Object item by its associated UTF-8 text
// - returns nil and raise no exception if aText doesn't exist
// - thread-safe method, unless returned TObject is deleted in the background
function GetObjectFrom(const aText: RawUTF8): pointer;
/// store a new RawUTF8 item
// - without the fNoDuplicate flag, it will always add the supplied value
// - if fNoDuplicate was set and aText already exists (using the internal
// hash table), it will return -1 unless aRaiseExceptionIfExisting is forced
// - thread-safe method
function Add(const aText: RawUTF8; aRaiseExceptionIfExisting: boolean=false): PtrInt; {$ifdef HASINLINE}inline;{$endif}
/// store a new RawUTF8 item, and its associated TObject
// - without the fNoDuplicate flag, it will always add the supplied value
// - if fNoDuplicate was set and aText already exists (using the internal hash
// table), it will return -1 unless aRaiseExceptionIfExisting is forced;
// optionally freeing the supplied aObject if aFreeAndReturnExistingObject
// is true, in which pointer the existing Objects[] is copied (see
// AddObjectUnique as a convenient wrapper around this behavior)
// - thread-safe method
function AddObject(const aText: RawUTF8; aObject: TObject;
aRaiseExceptionIfExisting: boolean=false; aFreeAndReturnExistingObject: PPointer=nil): PtrInt;
/// try to store a new RawUTF8 item and its associated TObject
// - fNoDuplicate should have been specified in the list flags
// - if aText doesn't exist, will add the values
// - if aText exist, will call aObjectToAddOrFree.Free and set the value
// already stored in Objects[] into aObjectToAddOrFree - allowing dual
// commit thread-safe update of the list, e.g. after a previous unsuccessful
// call to GetObjectFrom(aText)
// - thread-safe method, using an internal Hash Table to speedup IndexOf()
// - in fact, this method is just a wrapper around
// ! AddObject(aText,aObjectToAddOrFree^,false,@aObjectToAddOrFree);
procedure AddObjectUnique(const aText: RawUTF8; aObjectToAddOrFree: PPointer);
{$ifdef HASINLINE}inline;{$endif}
/// append a specified list to the current content
// - thread-safe method
procedure AddRawUTF8List(List: TRawUTF8List);
/// delete a stored RawUTF8 item, and its associated TObject
// - raise no exception in case of out of range supplied index
// - this method is not thread-safe: use Safe.Lock/UnLock if needed
procedure Delete(Index: PtrInt); overload;
/// delete a stored RawUTF8 item, and its associated TObject
// - will search for the value using IndexOf(aText), and returns its index
// - returns -1 if no entry was found and deleted
// - thread-safe method, using the internal Hash Table if fNoDuplicate is set
function Delete(const aText: RawUTF8): PtrInt; overload;
/// delete a stored RawUTF8 item, and its associated TObject, from
// a given Name when stored as 'Name=Value' pairs
// - raise no exception in case of out of range supplied index
// - thread-safe method, but not using the internal Hash Table
// - consider using TSynNameValue if you expect efficient name/value process
function DeleteFromName(const Name: RawUTF8): PtrInt; virtual;
/// find the index of a given Name when stored as 'Name=Value' pairs
// - search on Name is case-insensitive with 'Name=Value' pairs
// - this method is not thread-safe, and won't use the internal Hash Table
// - consider using TSynNameValue if you expect efficient name/value process
function IndexOfName(const Name: RawUTF8): PtrInt;
/// access to the Value of a given 'Name=Value' pair at a given position
// - this method is not thread-safe
// - consider using TSynNameValue if you expect efficient name/value process
function GetValueAt(Index: PtrInt): RawUTF8;
/// retrieve Value from an existing Name=Value, then optinally delete the entry
// - if Name is found, will fill Value with the stored content and return true
// - if Name is not found, Value is not modified, and false is returned
// - thread-safe method, but not using the internal Hash Table
// - consider using TSynNameValue if you expect efficient name/value process
function UpdateValue(const Name: RawUTF8; var Value: RawUTF8; ThenDelete: boolean): boolean;
/// retrieve and delete the first RawUTF8 item in the list
// - could be used as a FIFO, calling Add() as a "push" method
// - thread-safe method
function PopFirst(out aText: RawUTF8; aObject: PObject=nil): boolean;
/// retrieve and delete the last RawUTF8 item in the list
// - could be used as a FILO, calling Add() as a "push" method
// - thread-safe method
function PopLast(out aText: RawUTF8; aObject: PObject=nil): boolean;
/// erase all stored RawUTF8 items
// - and corresponding objects (if aOwnObjects was true at constructor)
// - thread-safe method, also clearing the internal Hash Table
procedure Clear; virtual;
/// find a RawUTF8 item in the stored Strings[] list
// - this search is case sensitive if fCaseSensitive flag was set (which
// is the default)
// - this method is not thread-safe since the internal list may change
// and the returned index may not be accurate any more
// - see also GetObjectFrom()
// - uses the internal Hash Table if fNoDuplicate was set
function IndexOf(const aText: RawUTF8): PtrInt;
/// find a TObject item index in the stored Objects[] list
// - this method is not thread-safe since the internal list may change
// and the returned index may not be accurate any more
// - aObject lookup won't use the internal Hash Table
function IndexOfObject(aObject: TObject): PtrInt;
/// search for any RawUTF8 item containing some text
// - uses PosEx() on the stored lines
// - this method is not thread-safe since the internal list may change
// and the returned index may not be accurate any more
// - by design, aText lookup can't use the internal Hash Table
function Contains(const aText: RawUTF8; aFirstIndex: integer=0): PtrInt;
/// retrieve the all lines, separated by the supplied delimiter
// - this method is thread-safe
function GetText(const Delimiter: RawUTF8=#13#10): RawUTF8;
/// the OnChange event will be raised only when EndUpdate will be called
// - this method will also call Safe.Lock for thread-safety
procedure BeginUpdate;
/// call the OnChange event if changes occured
// - this method will also call Safe.UnLock for thread-safety
procedure EndUpdate;
/// set low-level text and objects from existing arrays
procedure SetFrom(const aText: TRawUTF8DynArray; const aObject: TObjectDynArray);
/// set all lines, separated by the supplied delimiter
// - this method is thread-safe
procedure SetText(const aText: RawUTF8; const Delimiter: RawUTF8=#13#10);
/// set all lines from an UTF-8 text file
// - expect the file is explicitly an UTF-8 file
// - will ignore any trailing UTF-8 BOM in the file content, but will not
// expect one either
// - this method is thread-safe
procedure LoadFromFile(const FileName: TFileName);
/// write all lines into the supplied stream
// - this method is thread-safe
procedure SaveToStream(Dest: TStream; const Delimiter: RawUTF8=#13#10);
/// write all lines into a new file
// - this method is thread-safe
procedure SaveToFile(const FileName: TFileName; const Delimiter: RawUTF8=#13#10);
/// return the count of stored RawUTF8
// - reading this property is not thread-safe, since size may change
property Count: PtrInt read GetCount;
/// set or retrieve the current memory capacity of the RawUTF8 list
// - reading this property is not thread-safe, since size may change
property Capacity: PtrInt read GetCapacity write SetCapacity;
/// set if IndexOf() shall be case sensitive or not
// - default is TRUE
// - matches fCaseSensitive in Flags
property CaseSensitive: boolean read GetCaseSensitive write SetCaseSensitive;
/// set if the list doesn't allow duplicated UTF-8 text
// - if true, an internal hash table is maintained for faster IndexOf()
// - matches fNoDuplicate in Flags
property NoDuplicate: boolean read GetNoDuplicate;
/// access to the low-level flags of this list
property Flags: TRawUTF8ListFlags read fFlags write fFlags;
/// get or set a RawUTF8 item
// - returns '' and raise no exception in case of out of range supplied index
// - if you want to use it with the VCL, use UTF8ToString() function
// - reading this property is not thread-safe, since content may change
property Strings[Index: PtrInt]: RawUTF8 read Get write Put; default;
/// get or set a Object item
// - returns nil and raise no exception in case of out of range supplied index
// - reading this property is not thread-safe, since content may change
property Objects[Index: PtrInt]: pointer read GetObject write PutObject;
/// retrieve the corresponding Name when stored as 'Name=Value' pairs
// - reading this property is not thread-safe, since content may change
// - consider TSynNameValue if you expect more efficient name/value process
property Names[Index: PtrInt]: RawUTF8 read GetName;
/// access to the corresponding 'Name=Value' pairs
// - search on Name is case-insensitive with 'Name=Value' pairs
// - reading this property is thread-safe, but won't use the hash table
// - consider TSynNameValue if you expect more efficient name/value process
property Values[const Name: RawUTF8]: RawUTF8 read GetValue write SetValue;
/// the char separator between 'Name=Value' pairs
// - equals '=' by default
// - consider TSynNameValue if you expect more efficient name/value process
property NameValueSep: AnsiChar read fNameValueSep write fNameValueSep;
/// set or retrieve all items as text lines
// - lines are separated by #13#10 (CRLF) by default; use GetText and
// SetText methods if you want to use another line delimiter (even a comma)
// - this property is thread-safe
property Text: RawUTF8 read GetTextCRLF write SetTextCRLF;
/// Event triggered when an entry is modified
property OnChange: TNotifyEvent read fOnChange write fOnChange;
/// direct access to the memory of the TRawUTF8DynArray items
// - reading this property is not thread-safe, since content may change
property TextPtr: PPUtf8CharArray read GetTextPtr;
/// direct access to the memory of the TObjectDynArray items
// - reading this property is not thread-safe, since content may change
property ObjectPtr: PPointerArray read GetObjectPtr;
/// direct access to the TRawUTF8DynArray items dynamic array wrapper
// - using this property is not thread-safe, since content may change
property ValuesArray: TDynArrayHashed read fValues;
/// access to the locking methods of this instance
// - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block
property Safe: TSynLocker read fSafe;
end;
// some declarations used for backward compatibility only
TRawUTF8ListLocked = type TRawUTF8List;
TRawUTF8ListHashed = type TRawUTF8List;
TRawUTF8ListHashedLocked = type TRawUTF8ListHashed;
// deprecated TRawUTF8MethodList should be replaced by a TSynDictionary
/// define the implemetation used by TAlgoCompress.Decompress()
TAlgoCompressLoad = (aclNormal, aclSafeSlow, aclNoCrcFast);
/// abstract low-level parent class for generic compression/decompression algorithms
// - will encapsulate the compression algorithm with crc32c hashing
// - all Algo* abstract methods should be overriden by inherited classes
TAlgoCompress = class(TSynPersistent)
public
/// should return a genuine byte identifier
// - 0 is reserved for stored, 1 for TAlgoSynLz, 2/3 for TAlgoDeflate/Fast
// (in mORMot.pas), 4/5/6 for TAlgoLizard/Fast/Huffman (in SynLizard.pas)
function AlgoID: byte; virtual; abstract;
/// computes by default the crc32c() digital signature of the buffer
function AlgoHash(Previous: cardinal; Data: pointer; DataLen: integer): cardinal; virtual;
/// get maximum possible (worse) compressed size for the supplied length
function AlgoCompressDestLen(PlainLen: integer): integer; virtual; abstract;
/// this method will compress the supplied data
function AlgoCompress(Plain: pointer; PlainLen: integer; Comp: pointer): integer; virtual; abstract;
/// this method will return the size of the decompressed data
function AlgoDecompressDestLen(Comp: pointer): integer; virtual; abstract;
/// this method will decompress the supplied data
function AlgoDecompress(Comp: pointer; CompLen: integer; Plain: pointer): integer; virtual; abstract;
/// this method will partially and safely decompress the supplied data
// - expects PartialLen <= result < PartialLenMax, depending on the algorithm
function AlgoDecompressPartial(Comp: pointer; CompLen: integer;
Partial: pointer; PartialLen, PartialLenMax: integer): integer; virtual; abstract;
public
/// will register AlgoID in the global list, for Algo() class methods
// - no need to free this instance, since it will be owned by the global list
// - raise a ESynException if the class or its AlgoID are already registered
// - you should never have to call this constructor, but define a global
// variable holding a reference to a shared instance
constructor Create; override;
/// get maximum possible (worse) compressed size for the supplied length
// - including the crc32c + algo 9 bytes header
function CompressDestLen(PlainLen: integer): integer;
{$ifdef HASINLINE}inline;{$endif}
/// compress a memory buffer with crc32c hashing to a RawByteString
function Compress(const Plain: RawByteString; CompressionSizeTrigger: integer=100;
CheckMagicForCompressed: boolean=false; BufferOffset: integer=0): RawByteString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// compress a memory buffer with crc32c hashing to a RawByteString
function Compress(Plain: PAnsiChar; PlainLen: integer; CompressionSizeTrigger: integer=100;
CheckMagicForCompressed: boolean=false; BufferOffset: integer=0): RawByteString; overload;
/// compress a memory buffer with crc32c hashing
// - supplied Comp buffer should contain at least CompressDestLen(PlainLen) bytes
function Compress(Plain, Comp: PAnsiChar; PlainLen, CompLen: integer;
CompressionSizeTrigger: integer=100; CheckMagicForCompressed: boolean=false): integer; overload;
/// compress a memory buffer with crc32c hashing to a TByteDynArray
function CompressToBytes(const Plain: RawByteString; CompressionSizeTrigger: integer=100;
CheckMagicForCompressed: boolean=false): TByteDynArray; overload;
{$ifdef HASINLINE}inline;{$endif}
/// compress a memory buffer with crc32c hashing to a TByteDynArray
function CompressToBytes(Plain: PAnsiChar; PlainLen: integer; CompressionSizeTrigger: integer=100;
CheckMagicForCompressed: boolean=false): TByteDynArray; overload;
/// uncompress a RawByteString memory buffer with crc32c hashing
function Decompress(const Comp: RawByteString; Load: TAlgoCompressLoad=aclNormal;
BufferOffset: integer=0): RawByteString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// uncompress a RawByteString memory buffer with crc32c hashing
// - returns TRUE on success
function TryDecompress(const Comp: RawByteString; out Dest: RawByteString;
Load: TAlgoCompressLoad=aclNormal): boolean;
/// uncompress a memory buffer with crc32c hashing
procedure Decompress(Comp: PAnsiChar; CompLen: integer; out Result: RawByteString;
Load: TAlgoCompressLoad=aclNormal; BufferOffset: integer=0); overload;
/// uncompress a RawByteString memory buffer with crc32c hashing
function Decompress(const Comp: TByteDynArray): RawByteString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// uncompress a RawByteString memory buffer with crc32c hashing
// - returns nil if crc32 hash failed, i.e. if the supplied Comp is not correct
// - returns a pointer to the uncompressed data and fill PlainLen variable,
// after crc32c hash
// - avoid any memory allocation in case of a stored content - otherwise, would
// uncompress to the tmp variable, and return pointer(tmp) and length(tmp)
function Decompress(const Comp: RawByteString; out PlainLen: integer;
var tmp: RawByteString; Load: TAlgoCompressLoad=aclNormal): pointer; overload;
{$ifdef HASINLINE}inline;{$endif}
/// uncompress a RawByteString memory buffer with crc32c hashing
// - returns nil if crc32 hash failed, i.e. if the supplied Data is not correct
// - returns a pointer to an uncompressed data buffer of PlainLen bytes
// - avoid any memory allocation in case of a stored content - otherwise, would
// uncompress to the tmp variable, and return pointer(tmp) and length(tmp)
function Decompress(Comp: PAnsiChar; CompLen: integer; out PlainLen: integer;
var tmp: RawByteString; Load: TAlgoCompressLoad=aclNormal): pointer; overload;
/// decode the header of a memory buffer compressed via the Compress() method
// - validates the crc32c of the compressed data (unless Load=aclNoCrcFast),
// then return the uncompressed size in bytes, or 0 if the crc32c does not match
// - should call DecompressBody() later on to actually retrieve the content
function DecompressHeader(Comp: PAnsiChar; CompLen: integer;
Load: TAlgoCompressLoad=aclNormal): integer;
/// decode the content of a memory buffer compressed via the Compress() method
// - PlainLen has been returned by a previous call to DecompressHeader()
function DecompressBody(Comp,Plain: PAnsiChar; CompLen,PlainLen: integer;
Load: TAlgoCompressLoad=aclNormal): boolean;
/// partial decoding of a memory buffer compressed via the Compress() method
// - returns 0 on error, or how many bytes have been written to Partial
// - will call virtual AlgoDecompressPartial() which is slower, but expected
// to avoid any buffer overflow on the Partial destination buffer
// - some algorithms (e.g. Lizard) may need some additional bytes in the
// decode buffer, so PartialLenMax bytes should be allocated in Partial^,
// with PartialLenMax > expected PartialLen, and returned bytes may be >
// PartialLen, but always <= PartialLenMax
function DecompressPartial(Comp,Partial: PAnsiChar; CompLen,PartialLen,PartialLenMax: integer): integer;
/// get the TAlgoCompress instance corresponding to the AlgoID stored
// in the supplied compressed buffer
// - returns nil if no algorithm was identified
class function Algo(Comp: PAnsiChar; CompLen: integer): TAlgoCompress; overload;
{$ifdef HASINLINE}inline;{$endif}
/// get the TAlgoCompress instance corresponding to the AlgoID stored
// in the supplied compressed buffer
// - returns nil if no algorithm was identified
// - also identifies "stored" content in IsStored variable
class function Algo(Comp: PAnsiChar; CompLen: integer; out IsStored: boolean): TAlgoCompress; overload;
/// get the TAlgoCompress instance corresponding to the AlgoID stored
// in the supplied compressed buffer
// - returns nil if no algorithm was identified
class function Algo(const Comp: RawByteString): TAlgoCompress; overload;
{$ifdef HASINLINE}inline;{$endif}
/// get the TAlgoCompress instance corresponding to the AlgoID stored
// in the supplied compressed buffer
// - returns nil if no algorithm was identified
class function Algo(const Comp: TByteDynArray): TAlgoCompress; overload;
{$ifdef HASINLINE}inline;{$endif}
/// get the TAlgoCompress instance corresponding to the supplied AlgoID
// - returns nil if no algorithm was identified
// - stored content is identified as TAlgoSynLZ
class function Algo(AlgoID: byte): TAlgoCompress; overload;
/// quickly validate a compressed buffer content, without uncompression
// - extract the TAlgoCompress, and call DecompressHeader() to check the
// hash of the compressed data, and return then uncompressed size
// - returns 0 on error (e.g. unknown algorithm or incorrect hash)
class function UncompressedSize(const Comp: RawByteString): integer;
/// returns the algorithm name, from its classname
// - e.g. TAlgoSynLZ->'synlz' TAlgoLizard->'lizard' nil->'none'
function AlgoName: TShort16;
end;
/// implement our fast SynLZ compression as a TAlgoCompress class
// - please use the AlgoSynLZ global variable methods instead of the deprecated
// SynLZCompress/SynLZDecompress wrapper functions
TAlgoSynLZ = class(TAlgoCompress)
public
/// returns 1 as genuine byte identifier for SynLZ
function AlgoID: byte; override;
/// get maximum possible (worse) SynLZ compressed size for the supplied length
function AlgoCompressDestLen(PlainLen: integer): integer; override;
/// compress the supplied data using SynLZ
function AlgoCompress(Plain: pointer; PlainLen: integer; Comp: pointer): integer; override;
/// return the size of the SynLZ decompressed data
function AlgoDecompressDestLen(Comp: pointer): integer; override;
/// decompress the supplied data using SynLZ
function AlgoDecompress(Comp: pointer; CompLen: integer; Plain: pointer): integer; override;
/// partial (and safe) decompression of the supplied data using SynLZ
function AlgoDecompressPartial(Comp: pointer; CompLen: integer;
Partial: pointer; PartialLen, PartialLenMax: integer): integer; override;
end;
TAlgoCompressWithNoDestLenProcess = (doCompress, doUnCompress, doUncompressPartial);
/// abstract class storing the plain length before calling compression API
// - some libraries (e.g. Deflate or Lizard) don't provide the uncompressed
// length from its output buffer - inherit from this class to store this value
// as ToVarUInt32, and override the RawProcess abstract protected method
TAlgoCompressWithNoDestLen = class(TAlgoCompress)
protected
/// inherited classes should implement this single method for the actual process
// - dstMax is oinly used for doUncompressPartial
function RawProcess(src,dst: pointer; srcLen,dstLen,dstMax: integer;
process: TAlgoCompressWithNoDestLenProcess): integer; virtual; abstract;
public
/// performs the compression, storing PlainLen and calling protected RawProcess
function AlgoCompress(Plain: pointer; PlainLen: integer; Comp: pointer): integer; override;
/// return the size of the decompressed data (using FromVarUInt32)
function AlgoDecompressDestLen(Comp: pointer): integer; override;
/// performs the decompression, retrieving PlainLen and calling protected RawProcess
function AlgoDecompress(Comp: pointer; CompLen: integer; Plain: pointer): integer; override;
/// performs the decompression, retrieving PlainLen and calling protected RawProcess
function AlgoDecompressPartial(Comp: pointer; CompLen: integer;
Partial: pointer; PartialLen, PartialLenMax: integer): integer; override;
end;
// internal flag, used only by TSynDictionary.InArray protected method
TSynDictionaryInArray = (
iaFind, iaFindAndDelete, iaFindAndUpdate, iaFindAndAddIfNotExisting, iaAdd);
/// event called by TSynDictionary.ForEach methods to iterate over stored items
// - if the implementation method returns TRUE, will continue the loop
// - if the implementation method returns FALSE, will stop values browsing
// - aOpaque is a custom value specified at ForEach() method call
TSynDictionaryEvent = function(const aKey; var aValue; aIndex,aCount: integer;
aOpaque: pointer): boolean of object;
/// event called by TSynDictionary.DeleteDeprecated
// - called just before deletion: return false to by-pass this item
TSynDictionaryCanDeleteEvent = function(const aKey, aValue; aIndex: integer): boolean of object;
/// thread-safe dictionary to store some values from associated keys
// - will maintain a dynamic array of values, associated with a hash table
// for the keys, so that setting or retrieving values would be O(1)
// - all process is protected by a TSynLocker, so will be thread-safe
// - TDynArray is a wrapper which do not store anything, whereas this class
// is able to store both keys and values, and provide convenient methods to
// access the stored data, including JSON serialization and binary storage
TSynDictionary = class(TSynPersistentLock)
protected
fKeys: TDynArrayHashed;
fValues: TDynArray;
fTimeOut: TCardinalDynArray;
fTimeOuts: TDynArray;
fCompressAlgo: TAlgoCompress;
fOnCanDelete: TSynDictionaryCanDeleteEvent;
function InArray(const aKey,aArrayValue; aAction: TSynDictionaryInArray): boolean;
procedure SetTimeouts;
function ComputeNextTimeOut: cardinal;
function KeyFullHash(const Elem): cardinal;
function KeyFullCompare(const A,B): integer;
function GetCapacity: integer;
procedure SetCapacity(const Value: integer);
function GetTimeOutSeconds: cardinal;
public
/// initialize the dictionary storage, specifyng dynamic array keys/values
// - aKeyTypeInfo should be a dynamic array TypeInfo() RTTI pointer, which
// would store the keys within this TSynDictionary instance
// - aValueTypeInfo should be a dynamic array TypeInfo() RTTI pointer, which
// would store the values within this TSynDictionary instance
// - by default, string keys would be searched following exact case, unless
// aKeyCaseInsensitive is TRUE
// - you can set an optional timeout period, in seconds - you should call
// DeleteDeprecated periodically to search for deprecated items
constructor Create(aKeyTypeInfo,aValueTypeInfo: pointer;
aKeyCaseInsensitive: boolean=false; aTimeoutSeconds: cardinal=0;
aCompressAlgo: TAlgoCompress=nil); reintroduce; virtual;
/// finalize the storage
// - would release all internal stored values
destructor Destroy; override;
/// try to add a value associated with a primary key
// - returns the index of the inserted item, -1 if aKey is already existing
// - this method is thread-safe, since it will lock the instance
function Add(const aKey, aValue): integer;
/// store a value associated with a primary key
// - returns the index of the matching item
// - if aKey does not exist, a new entry is added
// - if aKey does exist, the existing entry is overriden with aValue
// - this method is thread-safe, since it will lock the instance
function AddOrUpdate(const aKey, aValue): integer;
/// clear the value associated via aKey
// - does not delete the entry, but reset its value
// - returns the index of the matching item, -1 if aKey was not found
// - this method is thread-safe, since it will lock the instance
function Clear(const aKey): integer;
/// delete all key/value stored in the current instance
procedure DeleteAll;
/// delete a key/value association from its supplied aKey
// - this would delete the entry, i.e. matching key and value pair
// - returns the index of the deleted item, -1 if aKey was not found
// - this method is thread-safe, since it will lock the instance
function Delete(const aKey): integer;
/// delete a key/value association from its internal index
// - this method is not thread-safe: you should use fSafe.Lock/Unlock
// e.g. then Find/FindValue to retrieve the index value
function DeleteAt(aIndex: integer): boolean;
/// search and delete all deprecated items according to TimeoutSeconds
// - returns how many items have been deleted
// - you can call this method very often: it will ensure that the
// search process will take place at most once every second
// - this method is thread-safe, but blocking during the process
function DeleteDeprecated: integer;
/// search of a primary key within the internal hashed dictionary
// - returns the index of the matching item, -1 if aKey was not found
// - if you want to access the value, you should use fSafe.Lock/Unlock:
// consider using Exists or FindAndCopy thread-safe methods instead
// - aUpdateTimeOut will update the associated timeout value of the entry
function Find(const aKey; aUpdateTimeOut: boolean=false): integer;
/// search of a primary key within the internal hashed dictionary
// - returns a pointer to the matching item, nil if aKey was not found
// - if you want to access the value, you should use fSafe.Lock/Unlock:
// consider using Exists or FindAndCopy thread-safe methods instead
// - aUpdateTimeOut will update the associated timeout value of the entry
function FindValue(const aKey; aUpdateTimeOut: boolean=false; aIndex: PInteger=nil): pointer;
/// search of a primary key within the internal hashed dictionary
// - returns a pointer to the matching or already existing item
// - if you want to access the value, you should use fSafe.Lock/Unlock:
// consider using Exists or FindAndCopy thread-safe methods instead
// - will update the associated timeout value of the entry, if applying
function FindValueOrAdd(const aKey; var added: boolean; aIndex: PInteger=nil): pointer;
/// search of a stored value by its primary key, and return a local copy
// - so this method is thread-safe
// - returns TRUE if aKey was found, FALSE if no match exists
// - will update the associated timeout value of the entry, unless
// aUpdateTimeOut is set to false
function FindAndCopy(const aKey; out aValue; aUpdateTimeOut: boolean=true): boolean;
/// search of a stored value by its primary key, then delete and return it
// - returns TRUE if aKey was found, fill aValue with its content,
// and delete the entry in the internal storage
// - so this method is thread-safe
// - returns FALSE if no match exists
function FindAndExtract(const aKey; out aValue): boolean;
/// search for a primary key presence
// - returns TRUE if aKey was found, FALSE if no match exists
// - this method is thread-safe
function Exists(const aKey): boolean;
/// apply a specified event over all items stored in this dictionnary
// - would browse the list in the adding order
// - returns the number of times OnEach has been called
// - this method is thread-safe, since it will lock the instance
function ForEach(const OnEach: TSynDictionaryEvent; Opaque: pointer=nil): integer; overload;
/// apply a specified event over matching items stored in this dictionnary
// - would browse the list in the adding order, comparing each key and/or
// value item with the supplied comparison functions and aKey/aValue content
// - returns the number of times OnMatch has been called, i.e. how many times
// KeyCompare(aKey,Keys[#])=0 or ValueCompare(aValue,Values[#])=0
// - this method is thread-safe, since it will lock the instance
function ForEach(const OnMatch: TSynDictionaryEvent;
KeyCompare,ValueCompare: TDynArraySortCompare; const aKey,aValue;
Opaque: pointer=nil): integer; overload;
/// touch the entry timeout field so that it won't be deprecated sooner
// - this method is not thread-safe, and is expected to be execute e.g.
// from a ForEach() TSynDictionaryEvent callback
procedure SetTimeoutAtIndex(aIndex: integer);
/// search aArrayValue item in a dynamic-array value associated via aKey
// - expect the stored value to be a dynamic array itself
// - would search for aKey as primary key, then use TDynArray.Find
// to delete any aArrayValue match in the associated dynamic array
// - returns FALSE if Values is not a tkDynArray, or if aKey or aArrayValue
// were not found
// - this method is thread-safe, since it will lock the instance
function FindInArray(const aKey, aArrayValue): boolean;
/// search of a stored key by its associated key, and return a key local copy
// - won't use any hashed index but TDynArray.IndexOf over fValues,
// so is much slower than FindAndCopy()
// - will update the associated timeout value of the entry, unless
// aUpdateTimeOut is set to false
// - so this method is thread-safe
// - returns TRUE if aValue was found, FALSE if no match exists
function FindKeyFromValue(const aValue; out aKey; aUpdateTimeOut: boolean=true): boolean;
/// add aArrayValue item within a dynamic-array value associated via aKey
// - expect the stored value to be a dynamic array itself
// - would search for aKey as primary key, then use TDynArray.Add
// to add aArrayValue to the associated dynamic array
// - returns FALSE if Values is not a tkDynArray, or if aKey was not found
// - this method is thread-safe, since it will lock the instance
function AddInArray(const aKey, aArrayValue): boolean;
/// add once aArrayValue within a dynamic-array value associated via aKey
// - expect the stored value to be a dynamic array itself
// - would search for aKey as primary key, then use
// TDynArray.FindAndAddIfNotExisting to add once aArrayValue to the
// associated dynamic array
// - returns FALSE if Values is not a tkDynArray, or if aKey was not found
// - this method is thread-safe, since it will lock the instance
function AddOnceInArray(const aKey, aArrayValue): boolean;
/// clear aArrayValue item of a dynamic-array value associated via aKey
// - expect the stored value to be a dynamic array itself
// - would search for aKey as primary key, then use TDynArray.FindAndDelete
// to delete any aArrayValue match in the associated dynamic array
// - returns FALSE if Values is not a tkDynArray, or if aKey or aArrayValue were
// not found
// - this method is thread-safe, since it will lock the instance
function DeleteInArray(const aKey, aArrayValue): boolean;
/// replace aArrayValue item of a dynamic-array value associated via aKey
// - expect the stored value to be a dynamic array itself
// - would search for aKey as primary key, then use TDynArray.FindAndUpdate
// to delete any aArrayValue match in the associated dynamic array
// - returns FALSE if Values is not a tkDynArray, or if aKey or aArrayValue were
// not found
// - this method is thread-safe, since it will lock the instance
function UpdateInArray(const aKey, aArrayValue): boolean;
{$ifndef DELPHI5OROLDER}
/// make a copy of the stored values
// - this method is thread-safe, since it will lock the instance during copy
// - resulting length(Dest) will match the exact values count
// - T*ObjArray will be reallocated and copied by content (using a temporary
// JSON serialization), unless ObjArrayByRef is true and pointers are copied
procedure CopyValues(out Dest; ObjArrayByRef: boolean=false);
{$endif DELPHI5OROLDER}
/// serialize the content as a "key":value JSON object
procedure SaveToJSON(W: TTextWriter; EnumSetsAsText: boolean=false); overload;
/// serialize the content as a "key":value JSON object
function SaveToJSON(EnumSetsAsText: boolean=false): RawUTF8; overload;
/// serialize the Values[] as a JSON array
function SaveValuesToJSON(EnumSetsAsText: boolean=false): RawUTF8;
/// unserialize the content from "key":value JSON object
// - if the JSON input may not be correct (i.e. if not coming from SaveToJSON),
// you may set EnsureNoKeyCollision=TRUE for a slow but safe keys validation
function LoadFromJSON(const JSON: RawUTF8 {$ifndef NOVARIANTS};
CustomVariantOptions: PDocVariantOptions=nil{$endif}): boolean; overload;
/// unserialize the content from "key":value JSON object
// - note that input JSON buffer is not modified in place: no need to create
// a temporary copy if the buffer is about to be re-used
function LoadFromJSON(JSON: PUTF8Char {$ifndef NOVARIANTS};
CustomVariantOptions: PDocVariantOptions=nil{$endif}): boolean; overload;
/// save the content as SynLZ-compressed raw binary data
// - warning: this format is tied to the values low-level RTTI, so if you
// change the value/key type definitions, LoadFromBinary() would fail
function SaveToBinary(NoCompression: boolean=false): RawByteString;
/// load the content from SynLZ-compressed raw binary data
// - as previously saved by SaveToBinary method
function LoadFromBinary(const binary: RawByteString): boolean;
/// can be assigned to OnCanDeleteDeprecated to check TSynPersistentLock(aValue).Safe.IsLocked
class function OnCanDeleteSynPersistentLock(const aKey, aValue; aIndex: integer): boolean;
/// can be assigned to OnCanDeleteDeprecated to check TSynPersistentLock(aValue).Safe.IsLocked
class function OnCanDeleteSynPersistentLocked(const aKey, aValue; aIndex: integer): boolean;
/// returns how many items are currently stored in this dictionary
// - this method is thread-safe
function Count: integer;
/// fast returns how many items are currently stored in this dictionary
// - this method is NOT thread-safe so should be protected by fSafe.Lock/UnLock
function RawCount: integer; {$ifdef HASINLINE}inline;{$endif}
/// direct access to the primary key identifiers
// - if you want to access the keys, you should use fSafe.Lock/Unlock
property Keys: TDynArrayHashed read fKeys;
/// direct access to the associated stored values
// - if you want to access the values, you should use fSafe.Lock/Unlock
property Values: TDynArray read fValues;
/// defines how many items are currently stored in Keys/Values internal arrays
property Capacity: integer read GetCapacity write SetCapacity;
/// direct low-level access to the internal access tick (GetTickCount64 shr 10)
// - may be nil if TimeOutSeconds=0
property TimeOut: TCardinalDynArray read fTimeOut;
/// returns the aTimeOutSeconds parameter value, as specified to Create()
property TimeOutSeconds: cardinal read GetTimeOutSeconds;
/// the compression algorithm used for binary serialization
property CompressAlgo: TAlgoCompress read fCompressAlgo write fCompressAlgo;
/// callback to by-pass DeleteDeprecated deletion by returning false
// - can be assigned e.g. to OnCanDeleteSynPersistentLock if Value is a
// TSynPersistentLock instance, to avoid any potential access violation
property OnCanDeleteDeprecated: TSynDictionaryCanDeleteEvent read fOnCanDelete write fOnCanDelete;
end;
/// event signature to locate a service for a given string key
// - used e.g. by TRawUTF8ObjectCacheList.OnKeyResolve property
TOnKeyResolve = function(const aInterface: TGUID; const Key: RawUTF8; out Obj): boolean of object;
/// event signature to notify a given string key
TOnKeyNotify = procedure(Sender: TObject; const Key: RawUTF8) of object;
var
/// mORMot.pas will registry here its T*ObjArray serialization process
// - will be used by TDynArray.GetIsObjArray
DynArrayIsObjArray: function(aDynArrayTypeInfo: Pointer): TPointerClassHashed;
type
/// handle memory mapping of a file content
TMemoryMap = object
protected
fBuf: PAnsiChar;
fBufSize: PtrUInt;
fFile: THandle;
{$ifdef MSWINDOWS}
fMap: THandle;
{$endif}
fFileSize: Int64;
fFileLocal: boolean;
public
/// map the corresponding file handle
// - if aCustomSize and aCustomOffset are specified, the corresponding
// map view if created (by default, will map whole file)
function Map(aFile: THandle; aCustomSize: PtrUInt=0; aCustomOffset: Int64=0): boolean; overload;
/// map the file specified by its name
// - file will be closed when UnMap will be called
function Map(const aFileName: TFileName): boolean; overload;
/// set a fixed buffer for the content
// - emulated a memory-mapping from an existing buffer
procedure Map(aBuffer: pointer; aBufferSize: PtrUInt); overload;
/// unmap the file
procedure UnMap;
/// retrieve the memory buffer mapped to the file content
property Buffer: PAnsiChar read fBuf;
/// retrieve the buffer size
property Size: PtrUInt read fBufSize;
/// retrieve the mapped file size
property FileSize: Int64 read fFileSize;
/// access to the low-level associated File handle (if any)
property FileHandle: THandle read fFile;
end;
{$M+}
/// able to read a UTF-8 text file using memory map
// - much faster than TStringList.LoadFromFile()
// - will ignore any trailing UTF-8 BOM in the file content, but will not
// expect one either
TMemoryMapText = class
protected
fLines: PPointerArray;
fLinesMax: integer;
fCount: integer;
fMapEnd: PUTF8Char;
fMap: TMemoryMap;
fFileName: TFileName;
fAppendedLines: TRawUTF8DynArray;
fAppendedLinesCount: integer;
function GetLine(aIndex: integer): RawUTF8; {$ifdef HASINLINE}inline;{$endif}
function GetString(aIndex: integer): string; {$ifdef HASINLINE}inline;{$endif}
/// call once by Create constructors when fMap has been initialized
procedure LoadFromMap(AverageLineLength: integer=32); virtual;
/// call once per line, from LoadFromMap method
// - default implementation will set fLines[fCount] := LineBeg;
// - override this method to add some per-line process at loading: it will
// avoid reading the entire file more than once
procedure ProcessOneLine(LineBeg, LineEnd: PUTF8Char); virtual;
public
/// initialize the memory mapped text file
// - this default implementation just do nothing but is called by overloaded
// constructors so may be overriden to initialize an inherited class
constructor Create; overload; virtual;
/// read an UTF-8 encoded text file
// - every line beginning is stored into LinePointers[]
constructor Create(const aFileName: TFileName); overload;
/// read an UTF-8 encoded text file content
// - every line beginning is stored into LinePointers[]
// - this overloaded constructor accept an existing memory buffer (some
// uncompressed data e.g.)
constructor Create(aFileContent: PUTF8Char; aFileSize: integer); overload;
/// release the memory map and internal LinePointers[]
destructor Destroy; override;
/// save the whole content into a specified stream
// - including any runtime appended values via AddInMemoryLine()
procedure SaveToStream(Dest: TStream; const Header: RawUTF8);
/// save the whole content into a specified file
// - including any runtime appended values via AddInMemoryLine()
// - an optional header text can be added to the beginning of the file
procedure SaveToFile(FileName: TFileName; const Header: RawUTF8='');
/// add a new line to the already parsed content
// - this line won't be stored in the memory mapped file, but stay in memory
// and appended to the existing lines, until this instance is released
procedure AddInMemoryLine(const aNewLine: RawUTF8); virtual;
/// clear all in-memory appended rows
procedure AddInMemoryLinesClear; virtual;
/// retrieve the number of UTF-8 chars of the given line
// - warning: no range check is performed about supplied index
function LineSize(aIndex: integer): integer;
{$ifdef HASINLINE}inline;{$endif}
/// check if there is at least a given number of UTF-8 chars in the given line
// - this is faster than LineSize(aIndex)<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
// - jus tlike TStringSTream, is designed for appending data, not modifying
// in-place, as requested e.g. by TTextWriter or TFileBufferWriter classes
TRawByteStringStream = class(TStream)
protected
fDataString: RawByteString;
fPosition: Integer;
procedure SetSize(NewSize: Longint); override;
public
/// initialize the storage, optionally with some RawByteString content
constructor Create(const aString: RawByteString=''); overload;
/// read some bytes from the internal storage
// - returns the number of bytes filled into Buffer (<=Count)
function Read(var Buffer; Count: Longint): Longint; override;
/// change the current Read/Write position, within current stored range
function Seek(Offset: Longint; Origin: Word): Longint; override;
/// append some data to the buffer
// - will resize the buffer, i.e. will replace the end of the string from
// the current position with the supplied data
function Write(const Buffer; Count: Longint): Longint; override;
/// direct low-level access to the internal RawByteString storage
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: PtrInt); 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: PtrUInt=0; aCustomOffset: Int64=0); overload;
/// create a TStream from a file content using fast memory mapping
// - if aCustomSize and aCustomOffset are specified, the corresponding
// map view if created (by default, will map whole file)
constructor Create(aFile: THandle;
aCustomSize: PtrUInt=0; aCustomOffset: Int64=0); overload;
/// release any internal mapped file instance
destructor Destroy; override;
/// the file name, if created from such Create(aFileName) constructor
property FileName: TFileName read fFileName;
end;
/// FileSeek() overloaded function, working with huge files
// - Delphi FileSeek() is buggy -> use this function to safe access files > 2 GB
// (thanks to sanyin for the report)
function FileSeek64(Handle: THandle; const Offset: Int64; Origin: cardinal): Int64;
/// wrapper to serialize a T*ObjArray dynamic array as JSON
// - as expected by TJSONSerializer.RegisterObjArrayForJSON()
function ObjArrayToJSON(const aObjArray;
aOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]): RawUTF8;
/// encode the supplied data as an UTF-8 valid JSON object content
// - data must be supplied two by two, as Name,Value pairs, e.g.
// ! JSONEncode(['name','John','year',1972]) = '{"name":"John","year":1972}'
// - or you can specify nested arrays or objects with '['..']' or '{'..'}':
// ! J := JSONEncode(['doc','{','name','John','abc','[','a','b','c',']','}','id',123]);
// ! assert(J='{"doc":{"name":"John","abc":["a","b","c"]},"id":123}');
// - note that, due to a Delphi compiler limitation, cardinal values should be
// type-casted to Int64() (otherwise the integer mapped value will be converted)
// - you can pass nil as parameter for a null JSON value
function JSONEncode(const NameValuePairs: array of const): RawUTF8; overload;
{$ifndef NOVARIANTS}
/// encode the supplied (extended) JSON content, with parameters,
// as an UTF-8 valid JSON object content
// - in addition to the JSON RFC specification strict mode, this method will
// handle some BSON-like extensions, e.g. unquoted field names:
// ! aJSON := JSONEncode('{id:?,%:{name:?,birthyear:?}}',['doc'],[10,'John',1982]);
// - you can use nested _Obj() / _Arr() instances
// ! aJSON := JSONEncode('{%:{$in:[?,?]}}',['type'],['food','snack']);
// ! aJSON := JSONEncode('{type:{$in:?}}',[],[_Arr(['food','snack'])]);
// ! // will both return
// ! '{"type":{"$in":["food","snack"]}}')
// - if the SynMongoDB unit is used in the application, the MongoDB Shell
// syntax will also be recognized to create TBSONVariant, like
// ! new Date() ObjectId() MinKey MaxKey /<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, due to a Delphi compiler limitation, cardinal values should be
// type-casted to Int64() (otherwise the integer mapped value will be converted)
function JSONEncodeArrayOfConst(const Values: array of const;
WithoutBraces: boolean=false): RawUTF8; overload;
/// encode the supplied array data as a valid JSON array content
// - if WithoutBraces is TRUE, no [ ] will be generated
// - note that, due to a Delphi compiler limitation, cardinal values should be
// type-casted to Int64() (otherwise the integer mapped value will be converted)
procedure JSONEncodeArrayOfConst(const Values: array of const;
WithoutBraces: boolean; var result: RawUTF8); overload;
/// encode as JSON {"name":value} object, from a potential SQL quoted value
// - will unquote the SQLValue using TTextWriter.AddQuotedStringAsJSON()
procedure JSONEncodeNameSQLValue(const Name,SQLValue: RawUTF8; var result: RawUTF8);
type
/// points to one value of raw UTF-8 content, decoded from a JSON buffer
// - used e.g. by JSONDecode() overloaded function to returns names/values
TValuePUTF8Char = object
public
/// a pointer to the actual UTF-8 text
Value: PUTF8Char;
/// how many UTF-8 bytes are stored in Value
ValueLen: PtrInt;
/// convert the value into a UTF-8 string
procedure ToUTF8(var Text: RawUTF8); overload; {$ifdef HASINLINE}inline;{$endif}
/// convert the value into a UTF-8 string
function ToUTF8: RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif}
/// convert the value into a VCL/generic string
function ToString: string;
/// convert the value into a signed integer
function ToInteger: PtrInt; {$ifdef HASINLINE}inline;{$endif}
/// convert the value into an unsigned integer
function ToCardinal: PtrUInt; {$ifdef HASINLINE}inline;{$endif}
/// will call IdemPropNameU() over the stored text Value
function Idem(const Text: RawUTF8): boolean; {$ifdef HASINLINE}inline;{$endif}
end;
/// used e.g. by JSONDecode() overloaded function to returns values
TValuePUTF8CharArray = array[0..maxInt div SizeOf(TValuePUTF8Char)-1] of TValuePUTF8Char;
PValuePUTF8CharArray = ^TValuePUTF8CharArray;
/// store one name/value pair of raw UTF-8 content, from a JSON buffer
// - used e.g. by JSONDecode() overloaded function or UrlEncodeJsonObject()
// to returns names/values
TNameValuePUTF8Char = record
/// a pointer to the actual UTF-8 name text
Name: PUTF8Char;
/// a pointer to the actual UTF-8 value text
Value: PUTF8Char;
/// how many UTF-8 bytes are stored in Name (should be integer, not PtrInt)
NameLen: integer;
/// how many UTF-8 bytes are stored in Value
ValueLen: integer;
end;
/// used e.g. by JSONDecode() overloaded function to returns name/value pairs
TNameValuePUTF8CharDynArray = array of TNameValuePUTF8Char;
/// decode the supplied UTF-8 JSON content for the supplied names
// - data will be set in Values, according to the Names supplied e.g.
// ! JSONDecode(JSON,['name','year'],@Values) -> Values[0].Value='John'; Values[1].Value='1972';
// - if any supplied name wasn't found its corresponding Values[] will be nil
// - this procedure will decode the JSON content in-memory, i.e. the PUtf8Char
// array is created inside JSON, which is therefore modified: make a private
// copy first if you want to reuse the JSON content
// - if HandleValuesAsObjectOrArray is TRUE, then this procedure will handle
// JSON arrays or objects
// - support enhanced JSON syntax, e.g. '{name:'"John",year:1972}' is decoded
// just like '{"name":'"John","year":1972}'
procedure JSONDecode(var JSON: RawUTF8; const Names: array of RawUTF8;
Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean=false); overload;
/// decode the supplied UTF-8 JSON content for the supplied names
// - an overloaded function when the JSON is supplied as a RawJSON variable
procedure JSONDecode(var JSON: RawJSON; const Names: array of RawUTF8;
Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean=false); overload;
/// decode the supplied UTF-8 JSON content for the supplied names
// - data will be set in Values, according to the Names supplied e.g.
// ! JSONDecode(P,['name','year'],Values) -> Values[0]^='John'; Values[1]^='1972';
// - if any supplied name wasn't found its corresponding Values[] will be nil
// - this procedure will decode the JSON content in-memory, i.e. the PUtf8Char
// array is created inside P, which is therefore modified: make a private
// copy first if you want to reuse the JSON content
// - if HandleValuesAsObjectOrArray is TRUE, then this procedure will handle
// JSON arrays or objects
// - if ValuesLen is set, ValuesLen[] will contain the length of each Values[]
// - returns a pointer to the next content item in the JSON buffer
function JSONDecode(P: PUTF8Char; const Names: array of RawUTF8;
Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean=false): PUTF8Char; overload;
/// decode the supplied UTF-8 JSON content into an array of name/value pairs
// - this procedure will decode the JSON content in-memory, i.e. the PUtf8Char
// array is created inside JSON, which is therefore modified: make a private
// copy first if you want to reuse the JSON content
// - the supplied JSON buffer should stay available until Name/Value pointers
// from returned Values[] are accessed
// - if HandleValuesAsObjectOrArray is TRUE, then this procedure will handle
// JSON arrays or objects
// - support enhanced JSON syntax, e.g. '{name:'"John",year:1972}' is decoded
// just like '{"name":'"John","year":1972}'
function JSONDecode(P: PUTF8Char; out Values: TNameValuePUTF8CharDynArray;
HandleValuesAsObjectOrArray: Boolean=false): PUTF8Char; overload;
/// decode the supplied UTF-8 JSON content for the one supplied name
// - this function will decode the JSON content in-memory, so will unescape it
// in-place: it must be called only once with the same JSON data
function JSONDecode(var JSON: RawUTF8; const aName: RawUTF8='result';
wasString: PBoolean=nil; HandleValuesAsObjectOrArray: Boolean=false): RawUTF8; overload;
/// retrieve a pointer to JSON string field content
// - returns either ':' for name field, either '}',',' for value field
// - returns nil on JSON content error
// - this function won't touch the JSON buffer, so you can call it before
// using in-place escape process via JSONDecode() or GetJSONField()
function JSONRetrieveStringField(P: PUTF8Char; out Field: PUTF8Char;
out FieldLen: integer; ExpectNameField: boolean): PUTF8Char;
{$ifdef HASINLINE}inline;{$endif}
/// efficient JSON field in-place decoding, within a UTF-8 encoded buffer
// - this function decodes in the P^ buffer memory itself (no memory allocation
// or copy), for faster process - so take care that P^ is not shared
// - PDest points to the next field to be decoded, or nil on JSON parsing error
// - EndOfObject (if not nil) is set to the JSON value char (',' ':' or '}' e.g.)
// - optional wasString is set to true if the JSON value was a JSON "string"
// - returns a PUTF8Char to the decoded value, with its optional length in Len^
// - '"strings"' are decoded as 'strings', with wasString=true, properly JSON
// unescaped (e.g. any \u0123 pattern would be converted into UTF-8 content)
// - null is decoded as nil, with wasString=false
// - true/false boolean values are returned as 'true'/'false', with wasString=false
// - any number value is returned as its ascii representation, with wasString=false
// - works for both field names or values (e.g. '"FieldName":' or 'Value,')
function GetJSONField(P: PUTF8Char; out PDest: PUTF8Char;
wasString: PBoolean=nil; EndOfObject: PUTF8Char=nil; Len: PInteger=nil): PUTF8Char;
/// decode a JSON field name in an UTF-8 encoded buffer
// - this function decodes in the P^ buffer memory itself (no memory allocation
// or copy), for faster process - so take care that P^ is not shared
// - it will return the property name (with an ending #0) or nil on error
// - this function will handle strict JSON property name (i.e. a "string"), but
// also MongoDB extended syntax, e.g. {age:{$gt:18}} or {'people.age':{$gt:18}}
// see @http://docs.mongodb.org/manual/reference/mongodb-extended-json
function GetJSONPropName(var P: PUTF8Char; Len: PInteger=nil): PUTF8Char; overload;
/// decode a JSON field name in an UTF-8 encoded shortstring variable
// - this function would left the P^ buffer memory untouched, so may be safer
// than the overloaded GetJSONPropName() function in some cases
// - it will return the property name as a local UTF-8 encoded shortstring,
// or PropName='' on error
// - this function won't unescape the property name, as strict JSON (i.e. a "st\"ring")
// - but it will handle MongoDB syntax, e.g. {age:{$gt:18}} or {'people.age':{$gt:18}}
// see @http://docs.mongodb.org/manual/reference/mongodb-extended-json
procedure GetJSONPropName(var P: PUTF8Char; out PropName: shortstring); overload;
/// decode a JSON content in an UTF-8 encoded buffer
// - GetJSONField() will only handle JSON "strings" or numbers - if
// HandleValuesAsObjectOrArray is TRUE, this function will process JSON {
// objects } or [ arrays ] and add a #0 at the end of it
// - this function decodes in the P^ buffer memory itself (no memory allocation
// or copy), for faster process - so take care that it is an unique string
// - returns a pointer to the value start, and moved P to the next field to
// be decoded, or P=nil in case of any unexpected input
// - wasString is set to true if the JSON value was a "string"
// - EndOfObject (if not nil) is set to the JSON value end char (',' ':' or '}')
// - if Len is set, it will contain the length of the returned pointer value
function GetJSONFieldOrObjectOrArray(var P: PUTF8Char; wasString: PBoolean=nil;
EndOfObject: PUTF8Char=nil; HandleValuesAsObjectOrArray: Boolean=false;
NormalizeBoolean: Boolean=true; Len: PInteger=nil): PUTF8Char;
/// retrieve the next JSON item as a RawJSON variable
// - buffer can be either any JSON item, i.e. a string, a number or even a
// JSON array (ending with ]) or a JSON object (ending with })
// - EndOfObject (if not nil) is set to the JSON value end char (',' ':' or '}')
procedure GetJSONItemAsRawJSON(var P: PUTF8Char; var result: RawJSON;
EndOfObject: PAnsiChar=nil);
/// retrieve the next JSON item as a RawUTF8 decoded buffer
// - buffer can be either any JSON item, i.e. a string, a number or even a
// JSON array (ending with ]) or a JSON object (ending with })
// - EndOfObject (if not nil) is set to the JSON value end char (',' ':' or '}')
// - just call GetJSONField(), and create a new RawUTF8 from the returned value,
// after proper unescape if wasString^=true
function GetJSONItemAsRawUTF8(var P: PUTF8Char; var output: RawUTF8;
wasString: PBoolean=nil; EndOfObject: PUTF8Char=nil): boolean;
/// test if the supplied buffer is a "string" value or a numerical value
// (floating point or integer), according to the characters within
// - this version will recognize null/false/true as strings
// - e.g. IsString('0')=false, IsString('abc')=true, IsString('null')=true
function IsString(P: PUTF8Char): boolean;
/// test if the supplied buffer is a "string" value or a numerical value
// (floating or integer), according to the JSON encoding schema
// - this version will NOT recognize JSON null/false/true as strings
// - e.g. IsStringJSON('0')=false, IsStringJSON('abc')=true,
// but IsStringJSON('null')=false
// - will follow the JSON definition of number, i.e. '0123' is a string (i.e.
// '0' is excluded at the begining of a number) and '123' is not a string
function IsStringJSON(P: PUTF8Char): boolean;
/// test if the supplied buffer is a correct JSON value
function IsValidJSON(P: PUTF8Char; len: PtrInt): boolean; overload;
/// test if the supplied buffer is a correct JSON value
function IsValidJSON(const s: RawUTF8): boolean; overload;
/// reach positon just after the current JSON item in the supplied UTF-8 buffer
// - buffer can be either any JSON item, i.e. a string, a number or even a
// JSON array (ending with ]) or a JSON object (ending with })
// - returns nil if the specified buffer is not valid JSON content
// - returns the position in buffer just after the item excluding the separator
// character - i.e. result^ may be ',','}',']'
function GotoEndJSONItem(P: PUTF8Char; strict: boolean=false): PUTF8Char;
/// reach the positon of the next JSON item in the supplied UTF-8 buffer
// - buffer can be either any JSON item, i.e. a string, a number or even a
// JSON array (ending with ]) or a JSON object (ending with })
// - returns nil if the specified number of items is not available in buffer
// - returns the position in buffer after the item including the separator
// character (optionally in EndOfObject) - i.e. result will be at the start of
// the next object, and EndOfObject may be ',','}',']'
function GotoNextJSONItem(P: PUTF8Char; NumberOfItemsToJump: cardinal=1;
EndOfObject: PAnsiChar=nil): PUTF8Char;
/// read the position of the JSON value just after a property identifier
// - this function will handle strict JSON property name (i.e. a "string"), but
// also MongoDB extended syntax, e.g. {age:{$gt:18}} or {'people.age':{$gt:18}}
// see @http://docs.mongodb.org/manual/reference/mongodb-extended-json
function GotoNextJSONPropName(P: PUTF8Char): PUTF8Char;
/// reach the position of the next JSON object of JSON array
// - first char is expected to be either '[' or '{'
// - will return nil in case of parsing error or unexpected end (#0)
// - will return the next character after ending ] or } - i.e. may be , } ]
function GotoNextJSONObjectOrArray(P: PUTF8Char): PUTF8Char; overload;
{$ifdef FPC}inline;{$endif}
/// reach the position of the next JSON object of JSON array
// - first char is expected to be just after the initial '[' or '{'
// - specify ']' or '}' as the expected EndChar
// - will return nil in case of parsing error or unexpected end (#0)
// - will return the next character after ending ] or } - i.e. may be , } ]
function GotoNextJSONObjectOrArray(P: PUTF8Char; EndChar: AnsiChar): PUTF8Char; overload;
{$ifdef FPC}inline;{$endif}
/// reach the position of the next JSON object of JSON array
// - first char is expected to be either '[' or '{'
// - this version expects a maximum position in PMax: it may be handy to break
// the parsing for HUGE content - used e.g. by JSONArrayCount(P,PMax)
// - will return nil in case of parsing error or if P reached PMax limit
// - will return the next character after ending ] or { - i.e. may be , } ]
function GotoNextJSONObjectOrArrayMax(P,PMax: PUTF8Char): PUTF8Char;
/// compute the number of elements of a JSON array
// - this will handle any kind of arrays, including those with nested
// JSON objects or arrays
// - incoming P^ should point to the first char AFTER the initial '[' (which
// may be a closing ']')
// - returns -1 if the supplied input is invalid, or the number of identified
// items in the JSON array buffer
function JSONArrayCount(P: PUTF8Char): integer; overload;
/// compute the number of elements of a JSON array
// - this will handle any kind of arrays, including those with nested
// JSON objects or arrays
// - incoming P^ should point to the first char after the initial '[' (which
// may be a closing ']')
// - this overloaded method will abort if P reaches a certain position: for
// really HUGE arrays, it is faster to allocate the content within the loop,
// not ahead of time
function JSONArrayCount(P,PMax: PUTF8Char): integer; overload;
/// go to the #nth item of a JSON array
// - implemented via a fast SAX-like approach: the input buffer is not changed,
// nor no memory buffer allocated neither content copied
// - returns nil if the supplied index is out of range
// - returns a pointer to the index-nth item in the JSON array (first index=0)
// - this will handle any kind of arrays, including those with nested
// JSON objects or arrays
// - incoming P^ should point to the first initial '[' char
function JSONArrayItem(P: PUTF8Char; Index: integer): PUTF8Char;
/// retrieve all elements of a JSON array
// - this will handle any kind of arrays, including those with nested
// JSON objects or arrays
// - incoming P^ should point to the first char AFTER the initial '[' (which
// may be a closing ']')
// - returns false if the supplied input is invalid
// - returns true on success, with Values[] pointing to each unescaped value,
// may be a JSON string, object, array of constant
function JSONArrayDecode(P: PUTF8Char; out Values: TPUTF8CharDynArray): boolean;
/// compute the number of fields in a JSON object
// - this will handle any kind of objects, including those with nested
// JSON objects or arrays
// - incoming P^ should point to the first char after the initial '{' (which
// may be a closing '}')
function JSONObjectPropCount(P: PUTF8Char): integer;
/// go to a named property of a JSON object
// - implemented via a fast SAX-like approach: the input buffer is not changed,
// nor no memory buffer allocated neither content copied
// - returns nil if the supplied property name does not exist
// - returns a pointer to the matching item in the JSON object
// - this will handle any kind of objects, including those with nested
// JSON objects or arrays
// - incoming P^ should point to the first initial '{' char
function JsonObjectItem(P: PUTF8Char; const PropName: RawUTF8;
PropNameFound: PRawUTF8=nil): PUTF8Char;
/// go to a property of a JSON object, by its full path, e.g. 'parent.child'
// - implemented via a fast SAX-like approach: the input buffer is not changed,
// nor no memory buffer allocated neither content copied
// - returns nil if the supplied property path does not exist
// - returns a pointer to the matching item in the JSON object
// - this will handle any kind of objects, including those with nested
// JSON objects or arrays
// - incoming P^ should point to the first initial '{' char
function JsonObjectByPath(JsonObject,PropPath: PUTF8Char): PUTF8Char;
/// return all matching properties of a JSON object
// - here the PropPath could be a comma-separated list of full paths,
// e.g. 'Prop1,Prop2' or 'Obj1.Obj2.Prop1,Obj1.Prop2'
// - returns '' if no property did match
// - returns a JSON object of all matching properties
// - this will handle any kind of objects, including those with nested
// JSON objects or arrays
// - incoming P^ should point to the first initial '{' char
function JsonObjectsByPath(JsonObject,PropPath: PUTF8Char): RawUTF8;
/// convert one JSON object into two JSON arrays of keys and values
// - i.e. makes the following transformation:
// $ {key1:value1,key2,value2...} -> [key1,key2...] + [value1,value2...]
// - this function won't allocate any memory during its process, nor
// modify the JSON input buffer
// - is the reverse of the TTextWriter.AddJSONArraysAsJSONObject() method
function JSONObjectAsJSONArrays(JSON: PUTF8Char; out keys,values: RawUTF8): boolean;
/// remove comments and trailing commas from a text buffer before passing it to JSON parser
// - handle two types of comments: starting from // till end of line
// or /* ..... */ blocks anywhere in the text content
// - trailing commas is replaced by ' ', so resulting JSON is valid for parsers
// what not allows trailing commas (browsers for example)
// - may be used to prepare configuration files before loading;
// for example we store server configuration in file config.json and
// put some comments in this file then code for loading is:
// !var cfg: RawUTF8;
// ! cfg := StringFromFile(ExtractFilePath(paramstr(0))+'Config.json');
// ! RemoveCommentsFromJSON(@cfg[1]);
// ! pLastChar := JSONToObject(sc,pointer(cfg),configValid);
procedure RemoveCommentsFromJSON(P: PUTF8Char);
const
/// standard header for an UTF-8 encoded XML file
XMLUTF8_HEADER = '<?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}ptQWord{$else}ptCardinal{$endif};
/// which TJSONCustomParserRTTIType types are not simple types
// - ptTimeLog is complex, since could be also TCreateTime or TModTime
PT_COMPLEXTYPES = [ptArray, ptRecord, ptCustom, ptTimeLog];
/// could be used to compute the index in a pointer list from its position
POINTERSHR = {$ifdef CPU64}3{$else}2{$endif};
/// could be used to compute the bitmask of a pointer integer
POINTERAND = {$ifdef CPU64}7{$else}3{$endif};
/// could be used to check all bits on a pointer
POINTERBITS = {$ifdef CPU64}64{$else}32{$endif};
{ ************ some other common types and conversion routines ************** }
type
/// timestamp stored as second-based Unix Time
// - i.e. the number of seconds since 1970-01-01 00:00:00 UTC
// - is stored as 64-bit value, so that it won't be affected by the
// "Year 2038" overflow issue
// - see TUnixMSTime for a millisecond resolution Unix Timestamp
// - use UnixTimeToDateTime/DateTimeToUnixTime functions to convert it to/from
// a regular TDateTime
// - use UnixTimeUTC to return the current timestamp, using fast OS API call
// - also one of the encodings supported by SQLite3 date/time functions
TUnixTime = type Int64;
/// timestamp stored as millisecond-based Unix Time
// - i.e. the number of milliseconds since 1970-01-01 00:00:00 UTC
// - see TUnixTime for a second resolution Unix Timestamp
// - use UnixMSTimeToDateTime/DateTimeToUnixMSTime functions to convert it
// to/from a regular TDateTime
// - also one of the JavaScript date encodings
TUnixMSTime = type Int64;
/// pointer to a timestamp stored as second-based Unix Time
PUnixTime = ^TUnixTime;
/// pointer to a timestamp stored as millisecond-based Unix Time
PUnixMSTime = ^TUnixMSTime;
/// dynamic array of timestamps stored as second-based Unix Time
TUnixTimeDynArray = array of TUnixTime;
/// dynamic array of timestamps stored as millisecond-based Unix Time
TUnixMSTimeDynArray = array of TUnixMSTime;
type
/// calling context of TSynLogExceptionToStr callbacks
TSynLogExceptionContext = record
/// the raised exception class
EClass: ExceptClass;
/// the Delphi Exception instance
// - may be nil for external/OS exceptions
EInstance: Exception;
/// the OS-level exception code
// - could be $0EEDFAE0 of $0EEDFADE for Delphi-generated exceptions
ECode: DWord;
/// the address where the exception occured
EAddr: PtrUInt;
/// the optional stack trace
EStack: PPtrUInt;
/// = FPC's RaiseProc() FrameCount if EStack is Frame: PCodePointer
EStackCount: integer;
/// the timestamp of this exception, as number of seconds since UNIX Epoch
// - UnixTimeUTC is faster than NowUTC or GetSystemTime
// - use UnixTimeToDateTime() to convert it into a regular TDateTime
ETimestamp: TUnixTime;
/// the logging level corresponding to this exception
// - may be either sllException or sllExceptionOS
ELevel: TSynLogInfo;
end;
/// global hook callback to customize exceptions logged by TSynLog
// - should return TRUE if all needed information has been logged by the
// event handler
// - should return FALSE if Context.EAddr and Stack trace is to be appended
TSynLogExceptionToStr = function(WR: TTextWriter; const Context: TSynLogExceptionContext): boolean;
{$M+}
/// generic parent class of all custom Exception types of this unit
// - all our classes inheriting from ESynException are serializable,
// so you could use ObjectToJSONDebug(anyESynException) to retrieve some
// extended information
ESynException = class(Exception)
protected
fRaisedAt: pointer;
public
/// constructor which will use FormatUTF8() instead of Format()
// - expect % as delimiter, so is less error prone than %s %d %g
// - will handle vtPointer/vtClass/vtObject/vtVariant kind of arguments,
// appending class name for any class or object, the hexa value for a
// pointer, or the JSON representation of any supplied TDocVariant
constructor CreateUTF8(const Format: RawUTF8; const Args: array of const);
/// constructor appending some FormatUTF8() content to the GetLastError
// - message will contain GetLastError value followed by the formatted text
// - expect % as delimiter, so is less error prone than %s %d %g
// - will handle vtPointer/vtClass/vtObject/vtVariant kind of arguments,
// appending class name for any class or object, the hexa value for a
// pointer, or the JSON representation of any supplied TDocVariant
constructor CreateLastOSError(const Format: RawUTF8; const Args: array of const;
const Trailer: RawUtf8 = 'OSError');
{$ifndef NOEXCEPTIONINTERCEPT}
/// can be used to customize how the exception is logged
// - this default implementation will call the DefaultSynLogExceptionToStr()
// function or the TSynLogExceptionToStrCustom global callback, if defined
// - override this method to provide a custom logging content
// - should return TRUE if Context.EAddr and Stack trace is not to be
// written (i.e. as for any TSynLogExceptionToStr callback)
function CustomLog(WR: TTextWriter; const Context: TSynLogExceptionContext): boolean; virtual;
{$endif}
/// the code location when this exception was triggered
// - populated by SynLog unit, during interception - so may be nil
// - you can use TSynMapFile.FindLocation(ESynException) class function to
// guess the corresponding source code line
// - will be serialized as "Address": hexadecimal and source code location
// (using TSynMapFile .map/.mab information) in TJSONSerializer.WriteObject
// when woStorePointer option is defined - e.g. with ObjectToJSONDebug()
property RaisedAt: pointer read fRaisedAt write fRaisedAt;
published
property Message;
end;
{$M-}
ESynExceptionClass = class of ESynException;
/// exception class associated to TDocVariant JSON/BSON document
EDocVariant = class(ESynException);
/// exception raised during TFastReader decoding
EFastReader = class(ESynException);
var
/// allow to customize the ESynException logging message
TSynLogExceptionToStrCustom: TSynLogExceptionToStr = nil;
{$ifndef NOEXCEPTIONINTERCEPT}
/// default exception logging callback - will be set by the SynLog unit
// - will add the default Exception details, including any Exception.Message
// - if the exception inherits from ESynException
// - returns TRUE: caller will then append ' at EAddr' and the stack trace
DefaultSynLogExceptionToStr: TSynLogExceptionToStr = nil;
{$endif}
/// convert a string into its INTEGER Curr64 (value*10000) representation
// - this type is compatible with Delphi currency memory map with PInt64(@Curr)^
// - fast conversion, using only integer operations
// - if NoDecimal is defined, will be set to TRUE if there is no decimal, AND
// the returned value will be an Int64 (not a PInt64(@Curr)^)
function StrToCurr64(P: PUTF8Char; NoDecimal: PBoolean=nil): Int64;
/// convert a string into its currency representation
// - will call StrToCurr64()
function StrToCurrency(P: PUTF8Char): currency;
{$ifdef HASINLINE}inline;{$endif}
/// convert a currency value into a string
// - fast conversion, using only integer operations
// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals)
function CurrencyToStr(Value: currency): RawUTF8;
{$ifdef HASINLINE}inline;{$endif}
/// convert an INTEGER Curr64 (value*10000) into a string
// - this type is compatible with Delphi currency memory map with PInt64(@Curr)^
// - fast conversion, using only integer operations
// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals)
function Curr64ToStr(const Value: Int64): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert an INTEGER Curr64 (value*10000) into a string
// - this type is compatible with Delphi currency memory map with PInt64(@Curr)^
// - fast conversion, using only integer operations
// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals)
procedure Curr64ToStr(const Value: Int64; var result: RawUTF8); overload;
/// convert an INTEGER Curr64 (value*10000) into a string
// - this type is compatible with Delphi currency memory map with PInt64(@Curr)^
// - fast conversion, using only integer operations
// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals)
// - return the number of chars written to Dest^
function Curr64ToPChar(const Value: Int64; Dest: PUTF8Char): PtrInt;
/// internal fast INTEGER Curr64 (value*10000) value to text conversion
// - expect the last available temporary char position in P
// - return the last written char position (write in reverse order in P^)
// - will return 0 for Value=0, or a string representation with always 4 decimals
// (e.g. 1->'0.0001' 500->'0.0500' 25000->'2.5000' 30000->'3.0000')
// - is called by Curr64ToPChar() and Curr64ToStr() functions
function StrCurr64(P: PAnsiChar; const Value: Int64): PAnsiChar;
/// truncate a Currency value to only 2 digits
// - implementation will use fast Int64 math to avoid any precision loss due to
// temporary floating-point conversion
function TruncTo2Digits(Value: Currency): Currency;
/// truncate a Currency value, stored as Int64, to only 2 digits
// - implementation will use fast Int64 math to avoid any precision loss due to
// temporary floating-point conversion
procedure TruncTo2DigitsCurr64(var Value: Int64);
{$ifdef HASINLINE}inline;{$endif}
/// truncate a Currency value, stored as Int64, to only 2 digits
// - implementation will use fast Int64 math to avoid any precision loss due to
// temporary floating-point conversion
function TruncTo2Digits64(Value: Int64): Int64;
{$ifdef HASINLINE}inline;{$endif}
/// simple, no banker rounding of a Currency value to only 2 digits
// - #.##51 will round to #.##+0.01 and #.##50 will be truncated to #.##
// - implementation will use fast Int64 math to avoid any precision loss due to
// temporary floating-point conversion
function SimpleRoundTo2Digits(Value: Currency): Currency;
/// simple, no banker rounding of a Currency value, stored as Int64, to only 2 digits
// - #.##51 will round to #.##+0.01 and #.##50 will be truncated to #.##
// - implementation will use fast Int64 math to avoid any precision loss due to
// temporary floating-point conversion
procedure SimpleRoundTo2DigitsCurr64(var Value: Int64);
var
/// a conversion table from hexa chars into binary data
// - returns 255 for any character out of 0..9,A..Z,a..z range
// - used e.g. by HexToBin() function
// - is defined globally, since may be used from an inlined function
ConvertHexToBin: TNormTableByte;
/// naive but efficient cache to avoid string memory allocation for
// 0..999 small numbers by Int32ToUTF8/UInt32ToUTF8
// - use around 16KB of heap (since each item consumes 16 bytes), but increase
// overall performance and reduce memory allocation (and fragmentation),
// especially during multi-threaded execution
// - noticeable when strings are used as array indexes (e.g. in SynMongoDB BSON)
// - is defined globally, since may be used from an inlined function
SmallUInt32UTF8: array[0..999] of RawUTF8;
/// fast conversion from hexa chars into binary data
// - BinBytes contain the bytes count to be converted: Hex^ must contain
// at least BinBytes*2 chars to be converted, and Bin^ enough space
// - if Bin=nil, no output data is written, but the Hex^ format is checked
// - return false if any invalid (non hexa) char is found in Hex^
// - using this function with Bin^ as an integer value will decode in big-endian
// order (most-signignifican byte first)
function HexToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: Integer): boolean; overload;
/// fast conversion with no validity check from hexa chars into binary data
procedure HexToBinFast(Hex: PAnsiChar; Bin: PByte; BinBytes: Integer);
/// conversion from octal C-like escape into binary data
// - \xxx is converted into a single xxx byte from octal, and \\ into \
// - will stop the conversion when Oct^=#0 or when invalid \xxx is reached
// - returns the number of bytes written to Bin^
function OctToBin(Oct: PAnsiChar; Bin: PByte): PtrInt; overload;
/// conversion from octal C-like escape into binary data
// - \xxx is converted into a single xxx byte from octal, and \\ into \
function OctToBin(const Oct: RawUTF8): RawByteString; overload;
/// fast conversion from one hexa char pair into a 8 bit AnsiChar
// - return false if any invalid (non hexa) char is found in Hex^
// - similar to HexToBin(Hex,nil,1)
function HexToCharValid(Hex: PAnsiChar): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// fast check if the supplied Hex buffer is an hexadecimal representation
// of a binary buffer of a given number of bytes
function IsHex(const Hex: RawByteString; BinBytes: integer): boolean;
/// fast conversion from one hexa char pair into a 8 bit AnsiChar
// - return false if any invalid (non hexa) char is found in Hex^
// - similar to HexToBin(Hex,Bin,1) but with Bin<>nil
// - use HexToCharValid if you want to check a hexadecimal char content
function HexToChar(Hex: PAnsiChar; Bin: PUTF8Char): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// fast conversion from two hexa bytes into a 16 bit UTF-16 WideChar
// - similar to HexToBin(Hex,@wordvar,2) + bswap(wordvar)
function HexToWideChar(Hex: PAnsiChar): cardinal;
{$ifdef HASINLINE}inline;{$endif}
/// fast conversion from binary data into hexa chars
// - BinBytes contain the bytes count to be converted: Hex^ must contain
// enough space for at least BinBytes*2 chars
// - using this function with BinBytes^ as an integer value will encode it
// in low-endian order (less-signignifican byte first): don't use it for display
procedure BinToHex(Bin, Hex: PAnsiChar; BinBytes: integer); overload;
/// fast conversion from hexa chars into binary data
function HexToBin(const Hex: RawUTF8): RawByteString; overload;
/// fast conversion from binary data into hexa chars
function BinToHex(const Bin: RawByteString): RawUTF8; overload;
/// fast conversion from binary data into hexa chars
function BinToHex(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload;
/// fast conversion from binary data into hexa chars, ready to be displayed
// - BinBytes contain the bytes count to be converted: Hex^ must contain
// enough space for at least BinBytes*2 chars
// - using this function with Bin^ as an integer value will encode it
// in big-endian order (most-signignifican byte first): use it for display
procedure BinToHexDisplay(Bin, Hex: PAnsiChar; BinBytes: integer); overload;
/// fast conversion from binary data into hexa chars, ready to be displayed
function BinToHexDisplay(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload;
/// fast conversion from binary data into lowercase hexa chars
// - BinBytes contain the bytes count to be converted: Hex^ must contain
// enough space for at least BinBytes*2 chars
// - using this function with BinBytes^ as an integer value will encode it
// in low-endian order (less-signignifican byte first): don't use it for display
procedure BinToHexLower(Bin, Hex: PAnsiChar; BinBytes: integer); overload;
/// fast conversion from binary data into lowercase hexa chars
function BinToHexLower(const Bin: RawByteString): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fast conversion from binary data into lowercase hexa chars
function BinToHexLower(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fast conversion from binary data into lowercase hexa chars
procedure BinToHexLower(Bin: PAnsiChar; BinBytes: integer; var result: RawUTF8); overload;
/// fast conversion from binary data into lowercase hexa chars
// - BinBytes contain the bytes count to be converted: Hex^ must contain
// enough space for at least BinBytes*2 chars
// - using this function with Bin^ as an integer value will encode it
// in big-endian order (most-signignifican byte first): use it for display
procedure BinToHexDisplayLower(Bin, Hex: PAnsiChar; BinBytes: PtrInt); overload;
/// fast conversion from binary data into lowercase hexa chars
function BinToHexDisplayLower(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload;
/// fast conversion from up to 127 bytes of binary data into lowercase hexa chars
function BinToHexDisplayLowerShort(Bin: PAnsiChar; BinBytes: integer): shortstring;
/// fast conversion from up to 64-bit of binary data into lowercase hexa chars
function BinToHexDisplayLowerShort16(Bin: Int64; BinBytes: integer): TShort16;
/// fast conversion from binary data into hexa lowercase chars, ready to be
// used as a convenient TFileName prefix
function BinToHexDisplayFile(Bin: PAnsiChar; BinBytes: integer): TFileName;
/// append one byte as hexadecimal char pairs, into a text buffer
function ByteToHex(P: PAnsiChar; Value: byte): PAnsiChar;
/// fast conversion from binary data to escaped text
// - non printable characters will be written as $xx hexadecimal codes
// - will be #0 terminated, with '...' characters trailing on overflow
// - ensure the destination buffer contains at least max*3+3 bytes, which is
// always the case when using LogEscape() and its local TLogEscape variable
function EscapeBuffer(s,d: PAnsiChar; len,max: integer): PAnsiChar;
const
/// maximum size, in bytes, of a TLogEscape / LogEscape() buffer
LOGESCAPELEN = 200;
type
/// buffer to be allocated on stack when using LogEscape()
TLogEscape = array[0..LOGESCAPELEN*3+5] of AnsiChar;
/// fill TLogEscape stack buffer with the (hexadecimal) chars of the input binary
// - up to LOGESCAPELEN (i.e. 200) bytes will be escaped and appended to a
// Local temp: TLogEscape variable, using the EscapeBuffer() low-level function
// - you can then log the resulting escaped text by passing the returned
// PAnsiChar as % parameter to a TSynLog.Log() method
// - the "enabled" parameter can be assigned from a process option, avoiding to
// process the escape if verbose logs are disabled
// - used e.g. to implement logBinaryFrameContent option for WebSockets
function LogEscape(source: PAnsiChar; sourcelen: integer; var temp: TLogEscape;
enabled: boolean=true): PAnsiChar;
{$ifdef HASINLINE}inline;{$endif}
/// returns a text buffer with the (hexadecimal) chars of the input binary
// - is much slower than LogEscape/EscapeToShort, but has no size limitation
function LogEscapeFull(source: PAnsiChar; sourcelen: integer): RawUTF8; overload;
/// returns a text buffer with the (hexadecimal) chars of the input binary
// - is much slower than LogEscape/EscapeToShort, but has no size limitation
function LogEscapeFull(const source: RawByteString): RawUTF8; overload;
/// fill a shortstring with the (hexadecimal) chars of the input text/binary
function EscapeToShort(source: PAnsiChar; sourcelen: integer): shortstring; overload;
/// fill a shortstring with the (hexadecimal) chars of the input text/binary
function EscapeToShort(const source: RawByteString): shortstring; overload;
/// fast conversion from a pointer data into hexa chars, ready to be displayed
// - use internally BinToHexDisplay()
function PointerToHex(aPointer: Pointer): RawUTF8; overload;
/// fast conversion from a pointer data into hexa chars, ready to be displayed
// - use internally BinToHexDisplay()
procedure PointerToHex(aPointer: Pointer; var result: RawUTF8); overload;
/// fast conversion from a pointer data into hexa chars, ready to be displayed
// - use internally BinToHexDisplay()
// - such result type would avoid a string allocation on heap
function PointerToHexShort(aPointer: Pointer): TShort16; overload;
/// fast conversion from a Cardinal value into hexa chars, ready to be displayed
// - use internally BinToHexDisplay()
// - reverse function of HexDisplayToCardinal()
function CardinalToHex(aCardinal: Cardinal): RawUTF8;
/// fast conversion from a Cardinal value into hexa chars, ready to be displayed
// - use internally BinToHexDisplayLower()
// - reverse function of HexDisplayToCardinal()
function CardinalToHexLower(aCardinal: Cardinal): RawUTF8;
/// fast conversion from a Cardinal value into hexa chars, ready to be displayed
// - use internally BinToHexDisplay()
// - such result type would avoid a string allocation on heap
function CardinalToHexShort(aCardinal: Cardinal): TShort16;
/// fast conversion from a Int64 value into hexa chars, ready to be displayed
// - use internally BinToHexDisplay()
// - reverse function of HexDisplayToInt64()
function Int64ToHex(aInt64: Int64): RawUTF8; overload;
/// fast conversion from a Int64 value into hexa chars, ready to be displayed
// - use internally BinToHexDisplay()
// - reverse function of HexDisplayToInt64()
procedure Int64ToHex(aInt64: Int64; var result: RawUTF8); overload;
/// fast conversion from a Int64 value into hexa chars, ready to be displayed
// - use internally BinToHexDisplay()
// - such result type would avoid a string allocation on heap
procedure Int64ToHexShort(aInt64: Int64; out result: TShort16); overload;
/// fast conversion from a Int64 value into hexa chars, ready to be displayed
// - use internally BinToHexDisplay()
// - such result type would avoid a string allocation on heap
function Int64ToHexShort(aInt64: Int64): TShort16; overload;
/// fast conversion from a Int64 value into hexa chars, ready to be displayed
// - use internally BinToHexDisplay()
// - reverse function of HexDisplayToInt64()
function Int64ToHexString(aInt64: Int64): string;
/// fast conversion from hexa chars into a binary buffer
function HexDisplayToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: integer): boolean;
/// fast conversion from hexa chars into a cardinal
// - reverse function of CardinalToHex()
// - returns false and set aValue=0 if Hex is not a valid hexadecimal 32-bit
// unsigned integer
// - returns true and set aValue with the decoded number, on success
function HexDisplayToCardinal(Hex: PAnsiChar; out aValue: cardinal): boolean;
{$ifndef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif}
// inline gives an error under release conditions with FPC
/// fast conversion from hexa chars into a cardinal
// - reverse function of Int64ToHex()
// - returns false and set aValue=0 if Hex is not a valid hexadecimal 64-bit
// signed integer
// - returns true and set aValue with the decoded number, on success
function HexDisplayToInt64(Hex: PAnsiChar; out aValue: Int64): boolean; overload;
{$ifndef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif}
{ inline gives an error under release conditions with FPC }
/// fast conversion from hexa chars into a cardinal
// - reverse function of Int64ToHex()
// - returns 0 if the supplied text buffer is not a valid hexadecimal 64-bit
// signed integer
function HexDisplayToInt64(const Hex: RawByteString): Int64; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fast conversion from binary data into Base64 encoded UTF-8 text
function BinToBase64(const s: RawByteString): RawUTF8; overload;
/// fast conversion from binary data into Base64 encoded UTF-8 text
function BinToBase64(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload;
/// fast conversion from a small binary data into Base64 encoded UTF-8 text
function BinToBase64Short(const s: RawByteString): shortstring; overload;
/// fast conversion from a small binary data into Base64 encoded UTF-8 text
function BinToBase64Short(Bin: PAnsiChar; BinBytes: integer): shortstring; overload;
/// fast conversion from binary data into prefixed/suffixed Base64 encoded UTF-8 text
// - with optional JSON_BASE64_MAGIC prefix (UTF-8 encoded \uFFF0 special code)
function BinToBase64(const data, Prefix, Suffix: RawByteString; WithMagic: boolean): RawUTF8; overload;
/// fast conversion from binary data into Base64 encoded UTF-8 text
// with JSON_BASE64_MAGIC prefix (UTF-8 encoded \uFFF0 special code)
function BinToBase64WithMagic(const data: RawByteString): RawUTF8; overload;
/// fast conversion from binary data into Base64 encoded UTF-8 text
// with JSON_BASE64_MAGIC prefix (UTF-8 encoded \uFFF0 special code)
function BinToBase64WithMagic(Data: pointer; DataLen: integer): RawUTF8; overload;
/// fast conversion from Base64 encoded text into binary data
// - is now just an alias to Base64ToBinSafe() overloaded function
// - returns '' if s was not a valid Base64-encoded input
function Base64ToBin(const s: RawByteString): RawByteString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fast conversion from Base64 encoded text into binary data
// - is now just an alias to Base64ToBinSafe() overloaded function
// - returns '' if sp/len buffer was not a valid Base64-encoded input
function Base64ToBin(sp: PAnsiChar; len: PtrInt): RawByteString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fast conversion from Base64 encoded text into binary data
// - is now just an alias to Base64ToBinSafe() overloaded function
// - returns false and data='' if sp/len buffer was invalid
function Base64ToBin(sp: PAnsiChar; len: PtrInt; var data: RawByteString): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fast conversion from Base64 encoded text into binary data
// - returns TRUE on success, FALSE if sp/len buffer was invvalid
function Base64ToBin(sp: PAnsiChar; len: PtrInt; var Blob: TSynTempBuffer): boolean; overload;
/// fast conversion from Base64 encoded text into binary data
// - returns TRUE on success, FALSE if base64 does not match binlen
// - nofullcheck is deprecated and not used any more, since nofullcheck=false
// is now processed with no performance cost
function Base64ToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt;
nofullcheck: boolean=true): boolean; overload;
/// fast conversion from Base64 encoded text into binary data
// - returns TRUE on success, FALSE if base64 does not match binlen
// - nofullcheck is deprecated and not used any more, since nofullcheck=false
// is now processed with no performance cost
function Base64ToBin(const base64: RawByteString; bin: PAnsiChar; binlen: PtrInt;
nofullcheck: boolean=true): boolean; overload;
/// fast conversion from Base64 encoded text into binary data
// - will check supplied text is a valid Base64 encoded stream
function Base64ToBinSafe(const s: RawByteString): RawByteString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fast conversion from Base64 encoded text into binary data
// - will check supplied text is a valid Base64 encoded stream
function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt): RawByteString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fast conversion from Base64 encoded text into binary data
// - will check supplied text is a valid Base64 encoded stream
function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt; var data: RawByteString): boolean; overload;
/// just a wrapper around Base64ToBin() for in-place decode of JSON_BASE64_MAGIC
// '\uFFF0base64encodedbinary' content into binary
// - input ParamValue shall have been checked to match the expected pattern
procedure Base64MagicDecode(var ParamValue: RawUTF8);
/// check and decode '\uFFF0base64encodedbinary' content into binary
// - this method will check the supplied value to match the expected
// JSON_BASE64_MAGIC pattern, decode and set Blob and return TRUE
function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: RawByteString): boolean; overload;
/// check and decode '\uFFF0base64encodedbinary' content into binary
// - this method will check the supplied value to match the expected
// JSON_BASE64_MAGIC pattern, decode and set Blob and return TRUE
function Base64MagicCheckAndDecode(Value: PUTF8Char; ValueLen: Integer;
var Blob: RawByteString): boolean; overload;
/// check and decode '\uFFF0base64encodedbinary' content into binary
// - this method will check the supplied value to match the expected
// JSON_BASE64_MAGIC pattern, decode and set Blob and return TRUE
function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: TSynTempBuffer): boolean; overload;
/// check if the supplied text is a valid Base64 encoded stream
function IsBase64(const s: RawByteString): boolean; overload;
/// check if the supplied text is a valid Base64 encoded stream
function IsBase64(sp: PAnsiChar; len: PtrInt): boolean; overload;
/// retrieve the expected encoded length after Base64 process
function BinToBase64Length(len: PtrUInt): PtrUInt;
{$ifdef HASINLINE}inline;{$endif}
/// retrieve the expected undecoded length of a Base64 encoded buffer
// - here len is the number of bytes in sp
function Base64ToBinLength(sp: PAnsiChar; len: PtrInt): PtrInt;
/// retrieve the expected undecoded length of a Base64 encoded buffer
// - here len is the number of bytes in sp
// - will check supplied text is a valid Base64 encoded stream
function Base64ToBinLengthSafe(sp: PAnsiChar; len: PtrInt): PtrInt;
/// direct low-level decoding of a Base64 encoded buffer
// - here len is the number of 4 chars chunks in sp input
// - deprecated low-level function: use Base64ToBin/Base64ToBinSafe instead
function Base64Decode(sp,rp: PAnsiChar; len: PtrInt): boolean;
/// fast conversion from binary data into Base64-like URI-compatible encoded text
// - in comparison to Base64 standard encoding, will trim any right-sided '='
// unsignificant characters, and replace '+' or '/' by '_' or '-'
function BinToBase64uri(const s: RawByteString): RawUTF8; overload;
/// fast conversion from a binary buffer into Base64-like URI-compatible encoded text
// - in comparison to Base64 standard encoding, will trim any right-sided '='
// unsignificant characters, and replace '+' or '/' by '_' or '-'
function BinToBase64uri(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload;
/// fast conversion from a binary buffer into Base64-like URI-compatible encoded shortstring
// - in comparison to Base64 standard encoding, will trim any right-sided '='
// unsignificant characters, and replace '+' or '/' by '_' or '-'
// - returns '' if BinBytes void or too big for the resulting shortstring
function BinToBase64uriShort(Bin: PAnsiChar; BinBytes: integer): shortstring;
/// conversion from any Base64 encoded value into URI-compatible encoded text
// - warning: will modify the supplied base64 string in-place
// - in comparison to Base64 standard encoding, will trim any right-sided '='
// unsignificant characters, and replace '+' or '/' by '_' or '-'
procedure Base64ToURI(var base64: RawUTF8);
/// low-level conversion from a binary buffer into Base64-like URI-compatible encoded text
// - you should rather use the overloaded BinToBase64uri() functions
procedure Base64uriEncode(rp, sp: PAnsiChar; len: cardinal);
/// retrieve the expected encoded length after Base64-URI process
// - in comparison to Base64 standard encoding, will trim any right-sided '='
// unsignificant characters, and replace '+' or '/' by '_' or '-'
function BinToBase64uriLength(len: PtrUInt): PtrUInt;
{$ifdef HASINLINE}inline;{$endif}
/// retrieve the expected undecoded length of a Base64-URI encoded buffer
// - here len is the number of bytes in sp
// - in comparison to Base64 standard encoding, will trim any right-sided '='
// unsignificant characters, and replace '+' or '/' by '_' or '-'
function Base64uriToBinLength(len: PtrInt): PtrInt;
/// fast conversion from Base64-URI encoded text into binary data
// - in comparison to Base64 standard encoding, will trim any right-sided '='
// unsignificant characters, and replace '+' or '/' by '_' or '-'
function Base64uriToBin(sp: PAnsiChar; len: PtrInt): RawByteString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fast conversion from Base64-URI encoded text into binary data
// - in comparison to Base64 standard encoding, will trim any right-sided '='
// unsignificant characters, and replace '+' or '/' by '_' or '-'
procedure Base64uriToBin(sp: PAnsiChar; len: PtrInt; var result: RawByteString); overload;
/// fast conversion from Base64-URI encoded text into binary data
// - caller should always execute temp.Done when finished with the data
// - in comparison to Base64 standard encoding, will trim any right-sided '='
// unsignificant characters, and replace '+' or '/' by '_' or '-'
function Base64uriToBin(sp: PAnsiChar; len: PtrInt; var temp: TSynTempBuffer): boolean; overload;
/// fast conversion from Base64-URI encoded text into binary data
// - in comparison to Base64 standard encoding, will trim any right-sided '='
// unsignificant characters, and replace '+' or '/' by '_' or '-'
function Base64uriToBin(const s: RawByteString): RawByteString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fast conversion from Base64-URI encoded text into binary data
// - in comparison to Base64 standard encoding, will trim any right-sided '='
// unsignificant characters, and replace '+' or '/' by '_' or '-'
// - will check supplied text is a valid Base64-URI encoded stream
function Base64uriToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt): boolean; overload;
/// fast conversion from Base64-URI encoded text into binary data
// - in comparison to Base64 standard encoding, will trim any right-sided '='
// unsignificant characters, and replace '+' or '/' by '_' or '-'
// - will check supplied text is a valid Base64-URI encoded stream
function Base64uriToBin(const base64: RawByteString; bin: PAnsiChar; binlen: PtrInt): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// direct low-level decoding of a Base64-URI encoded buffer
// - the buffer is expected to be at least Base64uriToBinLength() bytes long
// - returns true if the supplied sp[] buffer has been successfully decoded
// into rp[] - will break at any invalid character, so is always safe to use
// - in comparison to Base64 standard encoding, will trim any right-sided '='
// unsignificant characters, and replace '+' or '/' by '_' or '-'
// - you should better not use this, but Base64uriToBin() overloaded functions
function Base64uriDecode(sp,rp: PAnsiChar; len: PtrInt): boolean;
/// generate some pascal source code holding some data binary as constant
// - can store sensitive information (e.g. certificates) within the executable
// - generates a source code snippet of the following format:
// ! const
// ! // Comment
// ! ConstName: array[0..2] of byte = (
// ! $01,$02,$03);
procedure BinToSource(Dest: TTextWriter; const ConstName, Comment: RawUTF8;
Data: pointer; Len: integer; PerLine: integer=16); overload;
/// generate some pascal source code holding some data binary as constant
// - can store sensitive information (e.g. certificates) within the executable
// - generates a source code snippet of the following format:
// ! const
// ! // Comment
// ! ConstName: array[0..2] of byte = (
// ! $01,$02,$03);
function BinToSource(const ConstName, Comment: RawUTF8; Data: pointer;
Len: integer; PerLine: integer=16; const Suffix: RawUTF8=''): RawUTF8; overload;
/// revert the value as encoded by TTextWriter.AddInt18ToChars3() or Int18ToChars3()
// - no range check is performed: you should ensure that the incoming text
// follows the expected 3-chars layout
function Chars3ToInt18(P: pointer): cardinal;
{$ifdef HASINLINE}inline;{$endif}
/// compute the value as encoded by TTextWriter.AddInt18ToChars3() method
function Int18ToChars3(Value: cardinal): RawUTF8; overload;
/// compute the value as encoded by TTextWriter.AddInt18ToChars3() method
procedure Int18ToChars3(Value: cardinal; var result: RawUTF8); overload;
/// add the 4 digits of integer Y to P^ as '0000'..'9999'
procedure YearToPChar(Y: PtrUInt; P: PUTF8Char);
{$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif}
/// creates a 3 digits string from a 0..999 value as '000'..'999'
// - consider using UInt3DigitsToShort() to avoid temporary memory allocation,
// e.g. when used as FormatUTF8() parameter
function UInt3DigitsToUTF8(Value: Cardinal): RawUTF8;
{$ifdef HASINLINE}inline;{$endif}
/// creates a 4 digits string from a 0..9999 value as '0000'..'9999'
// - consider using UInt4DigitsToShort() to avoid temporary memory allocation,
// e.g. when used as FormatUTF8() parameter
function UInt4DigitsToUTF8(Value: Cardinal): RawUTF8;
{$ifdef HASINLINE}inline;{$endif}
type
/// used e.g. by UInt4DigitsToShort/UInt3DigitsToShort/UInt2DigitsToShort
// - such result type would avoid a string allocation on heap
TShort4 = string[4];
/// creates a 4 digits short string from a 0..9999 value
// - using TShort4 as returned string would avoid a string allocation on heap
// - could be used e.g. as parameter to FormatUTF8()
function UInt4DigitsToShort(Value: Cardinal): TShort4;
{$ifdef HASINLINE}inline;{$endif}
/// creates a 3 digits short string from a 0..999 value
// - using TShort4 as returned string would avoid a string allocation on heap
// - could be used e.g. as parameter to FormatUTF8()
function UInt3DigitsToShort(Value: Cardinal): TShort4;
{$ifdef HASINLINE}inline;{$endif}
/// creates a 2 digits short string from a 0..99 value
// - using TShort4 as returned string would avoid a string allocation on heap
// - could be used e.g. as parameter to FormatUTF8()
function UInt2DigitsToShort(Value: byte): TShort4;
{$ifdef HASINLINE}inline;{$endif}
/// creates a 2 digits short string from a 0..99 value
// - won't test Value>99 as UInt2DigitsToShort()
function UInt2DigitsToShortFast(Value: byte): TShort4;
{$ifdef HASINLINE}inline;{$endif}
/// compute CRC16-CCITT checkum on the supplied buffer
// - i.e. 16-bit CRC-CCITT, with polynomial x^16 + x^12 + x^5 + 1 ($1021)
// and $ffff as initial value
// - this version is not optimized for speed, but for correctness
function crc16(Data: PAnsiChar; Len: integer): cardinal;
// our custom efficient 32-bit hash/checksum function
// - a Fletcher-like checksum algorithm, not a hash function: has less colisions
// than Adler32 for short strings, but more than xxhash32 or crc32/crc32c
// - written in simple plain pascal, with no L1 CPU cache pollution, but we
// also provide optimized x86/x64 assembly versions, since the algorithm is used
// heavily e.g. for TDynArray binary serialization, TSQLRestStorageInMemory
// binary persistence, or CompressSynLZ/StreamSynLZ/FileSynLZ
// - some numbers on Linux x86_64:
// $ 2500 hash32 in 707us i.e. 3536067/s or 7.3 GB/s
// $ 2500 xxhash32 in 1.34ms i.e. 1861504/s or 3.8 GB/s
// $ 2500 crc32c in 943us i.e. 2651113/s or 5.5 GB/s (SSE4.2 disabled)
// $ 2500 crc32c in 387us i.e. 6459948/s or 13.4 GB/s (SSE4.2 enabled)
function Hash32(Data: PCardinalArray; Len: integer): cardinal; overload;
// our custom efficient 32-bit hash/checksum function
// - a Fletcher-like checksum algorithm, not a hash function: has less colisions
// than Adler32 for short strings, but more than xxhash32 or crc32/crc32c
// - overloaded function using RawByteString for binary content hashing,
// whatever the codepage is
function Hash32(const Text: RawByteString): cardinal; overload;
{$ifdef HASINLINE}inline;{$endif}
/// standard Kernighan & Ritchie hash from "The C programming Language", 3rd edition
// - simple and efficient code, but too much collisions for THasher
// - kr32() is 898.8 MB/s - crc32cfast() 1.7 GB/s, crc32csse42() 4.3 GB/s
function kr32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal;
/// simple FNV-1a hashing function
// - when run over our regression suite, is similar to crc32c() about collisions,
// and 4 times better than kr32(), but also slower than the others
// - fnv32() is 715.5 MB/s - kr32() 898.8 MB/s
// - this hash function should not be usefull, unless you need several hashing
// algorithms at once (e.g. if crc32c with diverse seeds is not enough)
function fnv32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal;
/// perform very fast xxHash hashing in 32-bit mode
// - will use optimized asm for x86/x64, or a pascal version on other CPUs
function xxHash32(crc: cardinal; P: PAnsiChar; len: integer): cardinal;
type
TCrc32tab = array[0..7,byte] of cardinal;
PCrc32tab = ^TCrc32tab;
var
/// tables used by crc32cfast() function
// - created with a polynom diverse from zlib's crc32() algorithm, but
// compatible with SSE 4.2 crc32 instruction
// - tables content is created from code in initialization section below
// - will also be used internally by SymmetricEncrypt, FillRandom and
// TSynUniqueIdentifierGenerator as 1KB master/reference key tables
crc32ctab: TCrc32tab;
/// compute CRC32C checksum on the supplied buffer on processor-neutral code
// - result is compatible with SSE 4.2 based hardware accelerated instruction
// - will use fast x86/x64 asm or efficient pure pascal implementation on ARM
// - result is not compatible with zlib's crc32() - not the same polynom
// - crc32cfast() is 1.7 GB/s, crc32csse42() is 4.3 GB/s
// - you should use crc32c() function instead of crc32cfast() or crc32csse42()
function crc32cfast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
/// compute CRC32C checksum on the supplied buffer using inlined code
// - if the compiler supports inlining, will compute a slow but safe crc32c
// checksum of the binary buffer, without calling the main crc32c() function
// - may be used e.g. to identify patched executable at runtime, for a licensing
// protection system
function crc32cinlined(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
{$ifdef HASINLINE}inline;{$endif}
/// compute CRC64C checksum on the supplied buffer, cascading two crc32c
// - will use SSE 4.2 hardware accelerated instruction, if available
// - will combine two crc32c() calls into a single Int64 result
// - by design, such combined hashes cannot be cascaded
function crc64c(buf: PAnsiChar; len: cardinal): Int64;
/// compute CRC63C checksum on the supplied buffer, cascading two crc32c
// - similar to crc64c, but with 63-bit, so no negative value: may be used
// safely e.g. as mORMot's TID source
// - will use SSE 4.2 hardware accelerated instruction, if available
// - will combine two crc32c() calls into a single Int64 result
// - by design, such combined hashes cannot be cascaded
function crc63c(buf: PAnsiChar; len: cardinal): Int64;
type
/// binary access to an unsigned 32-bit value (4 bytes in memory)
TDWordRec = record
case integer of
0: (V: DWord);
1: (L,H: word);
2: (B: array[0..3] of byte);
end;
/// points to the binary of an unsigned 32-bit value
PDWordRec = ^TDWordRec;
/// binary access to an unsigned 64-bit value (8 bytes in memory)
TQWordRec = record
case integer of
0: (V: Qword);
1: (L,H: cardinal);
2: (W: array[0..3] of word);
3: (B: array[0..7] of byte);
end;
/// points to the binary of an unsigned 64-bit value
PQWordRec = ^TQWordRec;
/// store a 128-bit hash value
// - e.g. a MD5 digest, or array[0..3] of cardinal (TBlock128)
// - consumes 16 bytes of memory
THash128 = array[0..15] of byte;
/// pointer to a 128-bit hash value
PHash128 = ^THash128;
/// store a 160-bit hash value
// - e.g. a SHA-1 digest
// - consumes 20 bytes of memory
THash160 = array[0..19] of byte;
/// pointer to a 160-bit hash value
PHash160 = ^THash160;
/// store a 192-bit hash value
// - consumes 24 bytes of memory
THash192 = array[0..23] of byte;
/// pointer to a 192-bit hash value
PHash192 = ^THash192;
/// store a 256-bit hash value
// - e.g. a SHA-256 digest, a TECCSignature result, or array[0..7] of cardinal
// - consumes 32 bytes of memory
THash256 = array[0..31] of byte;
/// pointer to a 256-bit hash value
PHash256 = ^THash256;
/// store a 384-bit hash value
// - e.g. a SHA-384 digest
// - consumes 48 bytes of memory
THash384 = array[0..47] of byte;
/// pointer to a 384-bit hash value
PHash384 = ^THash384;
/// store a 512-bit hash value
// - e.g. a SHA-512 digest, a TECCSignature result, or array[0..15] of cardinal
// - consumes 64 bytes of memory
THash512 = array[0..63] of byte;
/// pointer to a 512-bit hash value
PHash512 = ^THash512;
/// store a 128-bit buffer
// - e.g. an AES block
// - consumes 16 bytes of memory
TBlock128 = array[0..3] of cardinal;
/// pointer to a 128-bit buffer
PBlock128 = ^TBlock128;
/// map an infinite array of 128-bit hash values
// - each item consumes 16 bytes of memory
THash128Array = array[0..(maxInt div SizeOf(THash128))-1] of THash128;
/// pointer to an infinite array of 128-bit hash values
PHash128Array = ^THash128Array;
/// store several 128-bit hash values
// - e.g. MD5 digests
// - consumes 16 bytes of memory per item
THash128DynArray = array of THash128;
/// map a 128-bit hash as an array of lower bit size values
// - consumes 16 bytes of memory
THash128Rec = packed record
case integer of
0: (Lo,Hi: Int64);
1: (L,H: QWord);
2: (i0,i1,i2,i3: integer);
3: (c0,c1,c2,c3: cardinal);
4: (c: TBlock128);
5: (b: THash128);
6: (w: array[0..7] of word);
7: (l64,h64: Int64Rec);
end;
/// pointer to 128-bit hash map variable record
PHash128Rec = ^THash128Rec;
/// map an infinite array of 256-bit hash values
// - each item consumes 32 bytes of memory
THash256Array = array[0..(maxInt div SizeOf(THash256))-1] of THash256;
/// pointer to an infinite array of 256-bit hash values
PHash256Array = ^THash256Array;
/// store several 256-bit hash values
// - e.g. SHA-256 digests, TECCSignature results, or array[0..7] of cardinal
// - consumes 32 bytes of memory per item
THash256DynArray = array of THash256;
/// map a 256-bit hash as an array of lower bit size values
// - consumes 32 bytes of memory
THash256Rec = packed record
case integer of
0: (Lo,Hi: THash128);
1: (d0,d1,d2,d3: Int64);
2: (i0,i1,i2,i3,i4,i5,i6,i7: integer);
3: (c0,c1: TBlock128);
4: (b: THash256);
5: (q: array[0..3] of QWord);
6: (c: array[0..7] of cardinal);
7: (w: array[0..15] of word);
8: (l,h: THash128Rec);
end;
/// pointer to 256-bit hash map variable record
PHash256Rec = ^THash256Rec;
/// map an infinite array of 512-bit hash values
// - each item consumes 64 bytes of memory
THash512Array = array[0..(maxInt div SizeOf(THash512))-1] of THash512;
/// pointer to an infinite array of 512-bit hash values
PHash512Array = ^THash512Array;
/// store several 512-bit hash values
// - e.g. SHA-512 digests, or array[0..15] of cardinal
// - consumes 64 bytes of memory per item
THash512DynArray = array of THash512;
/// map a 512-bit hash as an array of lower bit size values
// - consumes 64 bytes of memory
THash512Rec = packed record
case integer of
0: (Lo,Hi: THash256);
1: (h0,h1,h2,h3: THash128);
2: (d0,d1,d2,d3,d4,d5,d6,d7: Int64);
3: (i0,i1,i2,i3,i4,i5,i6,i7,i8,i9,i10,i11,i12,i13,i14,i15: integer);
4: (c0,c1,c2,c3: TBlock128);
5: (b: THash512);
6: (b160: THash160);
7: (b384: THash384);
8: (w: array[0..31] of word);
9: (c: array[0..15] of cardinal);
10: (i: array[0..7] of Int64);
11: (r: array[0..3] of THash128Rec);
12: (l,h: THash256Rec);
end;
/// pointer to 512-bit hash map variable record
PHash512Rec = ^THash512Rec;
/// compute a 128-bit checksum on the supplied buffer, cascading two crc32c
// - will use SSE 4.2 hardware accelerated instruction, if available
// - will combine two crc32c() calls into a single TAESBlock result
// - by design, such combined hashes cannot be cascaded
procedure crc128c(buf: PAnsiChar; len: cardinal; out crc: THash128);
/// compute a proprietary 128-bit CRC of 128-bit binary buffers
// - to be used for regression tests only: crcblocks will use the fastest
// implementation available on the current CPU (e.g. with SSE 4.2 opcodes)
procedure crcblocksfast(crc128, data128: PBlock128; count: integer);
/// compute a proprietary 128-bit CRC of 128-bit binary buffers
// - apply four crc32c() calls on the 128-bit input chunks, into a 128-bit crc
// - its output won't match crc128c() value, which works on 8-bit input
// - will use SSE 4.2 hardware accelerated instruction, if available
// - is used e.g. by SynEcc's TECDHEProtocol.ComputeMAC for macCrc128c
var crcblocks: procedure(crc128, data128: PBlock128; count: integer)=crcblocksfast;
/// computation of our 128-bit CRC of a 128-bit binary buffer without SSE4.2
// - to be used for regression tests only: crcblock will use the fastest
// implementation available on the current CPU (e.g. with SSE 4.2 opcodes)
procedure crcblockNoSSE42(crc128, data128: PBlock128);
/// compute a proprietary 128-bit CRC of a 128-bit binary buffer
// - apply four crc32c() calls on the 128-bit input chunk, into a 128-bit crc
// - its output won't match crc128c() value, which works on 8-bit input
// - will use SSE 4.2 hardware accelerated instruction, if available
// - is used e.g. by SynCrypto's TAESCFBCRC to check for data integrity
var crcblock: procedure(crc128, data128: PBlock128) = crcblockNoSSE42;
/// returns TRUE if all 16 bytes of this 128-bit buffer equal zero
// - e.g. a MD5 digest, or an AES block
function IsZero(const dig: THash128): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// returns TRUE if all 16 bytes of both 128-bit buffers do match
// - e.g. a MD5 digest, or an AES block
// - this function is not sensitive to any timing attack, so is designed
// for cryptographic purpose - and it is also branchless therefore fast
function IsEqual(const A,B: THash128): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fill all 16 bytes of this 128-bit buffer with zero
// - may be used to cleanup stack-allocated content
// ! ... finally FillZero(digest); end;
procedure FillZero(out dig: THash128); overload;
/// fast O(n) search of a 128-bit item in an array of such values
function Hash128Index(P: PHash128Rec; Count: integer; h: PHash128Rec): integer;
{$ifdef CPU64} inline; {$endif}
/// convert a 32-bit integer (storing a IP4 address) into its full notation
// - returns e.g. '1.2.3.4' for any valid address, or '' if ip4=0
function IP4Text(ip4: cardinal): shortstring; overload;
/// convert a 128-bit buffer (storing an IP6 address) into its full notation
// - returns e.g. '2001:0db8:0a0b:12f0:0000:0000:0000:0001'
function IP6Text(ip6: PHash128): shortstring; overload; {$ifdef HASINLINE}inline;{$endif}
/// convert a 128-bit buffer (storing an IP6 address) into its full notation
// - returns e.g. '2001:0db8:0a0b:12f0:0000:0000:0000:0001'
procedure IP6Text(ip6: PHash128; result: PShortString); overload;
/// compute a 256-bit checksum on the supplied buffer using crc32c
// - will use SSE 4.2 hardware accelerated instruction, if available
// - will combine two crc32c() calls into a single THash256 result
// - by design, such combined hashes cannot be cascaded
procedure crc256c(buf: PAnsiChar; len: cardinal; out crc: THash256);
/// returns TRUE if all 20 bytes of this 160-bit buffer equal zero
// - e.g. a SHA-1 digest
function IsZero(const dig: THash160): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// returns TRUE if all 20 bytes of both 160-bit buffers do match
// - e.g. a SHA-1 digest
// - this function is not sensitive to any timing attack, so is designed
// for cryptographic purpose
function IsEqual(const A,B: THash160): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fill all 20 bytes of this 160-bit buffer with zero
// - may be used to cleanup stack-allocated content
// ! ... finally FillZero(digest); end;
procedure FillZero(out dig: THash160); overload;
/// returns TRUE if all 32 bytes of this 256-bit buffer equal zero
// - e.g. a SHA-256 digest, or a TECCSignature result
function IsZero(const dig: THash256): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// returns TRUE if all 32 bytes of both 256-bit buffers do match
// - e.g. a SHA-256 digest, or a TECCSignature result
// - this function is not sensitive to any timing attack, so is designed
// for cryptographic purpose
function IsEqual(const A,B: THash256): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fill all 32 bytes of this 256-bit buffer with zero
// - may be used to cleanup stack-allocated content
// ! ... finally FillZero(digest); end;
procedure FillZero(out dig: THash256); overload;
/// fast O(n) search of a 256-bit item in an array of such values
function Hash256Index(P: PHash256Rec; Count: integer; h: PHash256Rec): integer; overload;
/// returns TRUE if all 48 bytes of this 384-bit buffer equal zero
// - e.g. a SHA-384 digest
function IsZero(const dig: THash384): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// returns TRUE if all 48 bytes of both 384-bit buffers do match
// - e.g. a SHA-384 digest
// - this function is not sensitive to any timing attack, so is designed
// for cryptographic purpose
function IsEqual(const A,B: THash384): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fill all 32 bytes of this 384-bit buffer with zero
// - may be used to cleanup stack-allocated content
// ! ... finally FillZero(digest); end;
procedure FillZero(out dig: THash384); overload;
/// returns TRUE if all 64 bytes of this 512-bit buffer equal zero
// - e.g. a SHA-512 digest
function IsZero(const dig: THash512): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// returns TRUE if all 64 bytes of both 512-bit buffers do match
// - e.g. two SHA-512 digests
// - this function is not sensitive to any timing attack, so is designed
// for cryptographic purpose
function IsEqual(const A,B: THash512): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fill all 64 bytes of this 512-bit buffer with zero
// - may be used to cleanup stack-allocated content
// ! ... finally FillZero(digest); end;
procedure FillZero(out dig: THash512); overload;
/// compute a 512-bit checksum on the supplied buffer using crc32c
// - will use SSE 4.2 hardware accelerated instruction, if available
// - will combine two crc32c() calls into a single THash512 result
// - by design, such combined hashes cannot be cascaded
procedure crc512c(buf: PAnsiChar; len: cardinal; out crc: THash512);
/// fill all bytes of this memory buffer with zeros, i.e. 'toto' -> #0#0#0#0
// - will write the memory buffer directly, so if this string instance is shared
// (i.e. has refcount>1), all other variables will contains zeros
// - may be used to cleanup stack-allocated content
// ! ... finally FillZero(secret); end;
procedure FillZero(var secret: RawByteString); overload;
{$ifdef FPC}inline;{$endif}
/// fill all bytes of this UTF-8 string with zeros, i.e. 'toto' -> #0#0#0#0
// - will write the memory buffer directly, so if this string instance is shared
// (i.e. has refcount>1), all other variables will contains zeros
// - may be used to cleanup stack-allocated content
// ! ... finally FillZero(secret); end;
procedure FillZero(var secret: RawUTF8); overload;
{$ifdef FPC}inline;{$endif}
/// fill all bytes of a memory buffer with zero
// - just redirect to FillCharFast(..,...,0)
procedure FillZero(var dest; count: PtrInt); overload;
{$ifdef HASINLINE}inline;{$endif}
/// returns TRUE if all bytes of both buffers do match
// - this function is not sensitive to any timing attack, so is designed
// for cryptographic purposes - use CompareMem/CompareMemSmall/CompareMemFixed
// as faster alternatives for general-purpose code
function IsEqual(const A,B; count: PtrInt): boolean; overload;
/// fast computation of two 64-bit unsigned integers into a 128-bit value
procedure mul64x64(const left, right: QWord; out product: THash128Rec);
{$ifndef CPUINTEL}inline;{$endif}
type
/// the potential features, retrieved from an Intel CPU
// - see https://en.wikipedia.org/wiki/CPUID#EAX.3D1:_Processor_Info_and_Feature_Bits
// - is defined on all platforms, since an ARM desktop could browse Intel logs
TIntelCpuFeature = (
{ CPUID 1 in EDX }
cfFPU, cfVME, cfDE, cfPSE, cfTSC, cfMSR, cfPAE, cfMCE,
cfCX8, cfAPIC, cf_d10, cfSEP, cfMTRR, cfPGE, cfMCA, cfCMOV,
cfPAT, cfPSE36, cfPSN, cfCLFSH, cf_d20, cfDS, cfACPI, cfMMX,
cfFXSR, cfSSE, cfSSE2, cfSS, cfHTT, cfTM, cfIA64, cfPBE,
{ CPUID 1 in ECX }
cfSSE3, cfCLMUL, cfDS64, cfMON, cfDSCPL, cfVMX, cfSMX, cfEST,
cfTM2, cfSSSE3, cfCID, cfSDBG, cfFMA, cfCX16, cfXTPR, cfPDCM,
cf_c16, cfPCID, cfDCA, cfSSE41, cfSSE42, cfX2A, cfMOVBE, cfPOPCNT,
cfTSC2, cfAESNI, cfXS, cfOSXS, cfAVX, cfF16C, cfRAND, cfHYP,
{ extended features CPUID 7 in EBX, ECX, EDX }
cfFSGS, cfTSCADJ, cfSGX, cfBMI1, cfHLE, cfAVX2, cfFDPEO, cfSMEP,
cfBMI2, cfERMS, cfINVPCID, cfRTM, cfPQM, cf_b13, cfMPX, cfPQE,
cfAVX512F, cfAVX512DQ, cfRDSEED, cfADX, cfSMAP, cfAVX512IFMA, cfPCOMMIT, cfCLFLUSH,
cfCLWB, cfIPT, cfAVX512PF, cfAVX512ER, cfAVX512CD, cfSHA, cfAVX512BW, cfAVX512VL,
cfPREFW1, cfAVX512VBMI, cfUMIP, cfPKU, cfOSPKE, cf_c05, cfAVX512VBMI2, cfCETSS,
cfGFNI, cfVAES, cfVCLMUL, cfAVX512NNI, cfAVX512BITALG, cf_c13, cfAVX512VPC, cf_c15,
cfFLP, cf_c17, cf_c18, cf_c19, cf_c20, cf_c21, cfRDPID, cf_c23,
cf_c24, cfCLDEMOTE, cf_c26, cfMOVDIRI, cfMOVDIR64B, cfENQCMD, cfSGXLC, cfPKS,
cf_d0, cf_d1, cfAVX512NNIW, cfAVX512MAPS, cfFSRM, cf_d5, cf_d6, cf_d7,
cfAVX512VP2I, cfSRBDS, cfMDCLR, cf_d11, cf_d12, cfTSXFA, cfSER, cfHYBRID,
cfTSXLDTRK, cf_d17, cfPCFG, cfLBR, cfIBT, cf_d21, cfAMXBF16, cf_d23,
cfAMXTILE, cfAMXINT8, cfIBRSPB, cfSTIBP, cfL1DFL, cfARCAB, cfCORCAB, cfSSBD);
/// all features, as retrieved from an Intel CPU
TIntelCpuFeatures = set of TIntelCpuFeature;
/// convert Intel CPU features as plain CSV text
function ToText(const aIntelCPUFeatures: TIntelCpuFeatures;
const Sep: RawUTF8=','): RawUTF8; overload;
{$ifdef CPUINTEL}
var
/// the available CPU features, as recognized at program startup
CpuFeatures: TIntelCpuFeatures;
/// compute CRC32C checksum on the supplied buffer using SSE 4.2
// - use Intel Streaming SIMD Extensions 4.2 hardware accelerated instruction
// - SSE 4.2 shall be available on the processor (i.e. cfSSE42 in CpuFeatures)
// - result is not compatible with zlib's crc32() - not the same polynom
// - crc32cfast() is 1.7 GB/s, crc32csse42() is 4.3 GB/s
// - you should use crc32c() function instead of crc32cfast() or crc32csse42()
function crc32csse42(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
{$endif CPUINTEL}
/// naive symmetric encryption scheme using a 32-bit key
// - fast, but not very secure, since uses crc32ctab[] content as master cypher
// key: consider using SynCrypto proven AES-based algorithms instead
procedure SymmetricEncrypt(key: cardinal; var data: RawByteString);
type
TCrc32cBy4 = function(crc, value: cardinal): cardinal;
var
/// compute CRC32C checksum on the supplied buffer
// - result is not compatible with zlib's crc32() - Intel/SCSI CRC32C is not
// the same polynom - but will use the fastest mean available, e.g. SSE 4.2,
// to achieve up to 16GB/s with the optimized implementation from SynCrypto.pas
// - you should use this function instead of crc32cfast() or crc32csse42()
crc32c: THasher;
/// compute CRC32C checksum on one 32-bit unsigned integer
// - can be used instead of crc32c() for inlined process during data acquisition
// - doesn't make "crc := not crc" before and after the computation: caller has
// to start with "crc := cardinal(not 0)" and make "crc := not crc" at the end,
// to compute the very same hash value than regular crc32c()
// - this variable will use the fastest mean available, e.g. SSE 4.2
crc32cBy4: TCrc32cBy4;
/// compute the hexadecimal representation of the crc32 checkum of a given text
// - wrapper around CardinalToHex(crc32c(...))
function crc32cUTF8ToHex(const str: RawUTF8): RawUTF8;
var
/// the default hasher used by TDynArrayHashed
// - set to crc32csse42() if SSE4.2 instructions are available on this CPU,
// or fallback to xxHash32() which performs better than crc32cfast()
DefaultHasher: THasher;
/// the hash function used by TRawUTF8Interning
// - set to crc32csse42() if SSE4.2 instructions are available on this CPU,
// or fallback to xxHash32() which performs better than crc32cfast()
InterningHasher: THasher;
/// retrieve a particular bit status from a bit array
// - this function can't be inlined, whereas GetBitPtr() function can
function GetBit(const Bits; aIndex: PtrInt): boolean;
/// set a particular bit into a bit array
// - this function can't be inlined, whereas SetBitPtr() function can
procedure SetBit(var Bits; aIndex: PtrInt);
/// unset/clear a particular bit into a bit array
// - this function can't be inlined, whereas UnSetBitPtr() function can
procedure UnSetBit(var Bits; aIndex: PtrInt);
/// retrieve a particular bit status from a bit array
// - GetBit() can't be inlined, whereas this pointer-oriented function can
function GetBitPtr(Bits: pointer; aIndex: PtrInt): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// set a particular bit into a bit array
// - SetBit() can't be inlined, whereas this pointer-oriented function can
procedure SetBitPtr(Bits: pointer; aIndex: PtrInt);
{$ifdef HASINLINE}inline;{$endif}
/// unset/clear a particular bit into a bit array
// - UnSetBit() can't be inlined, whereas this pointer-oriented function can
procedure UnSetBitPtr(Bits: pointer; aIndex: PtrInt);
{$ifdef HASINLINE}inline;{$endif}
/// compute the number of bits set in a bit array
// - Count is the bit count, not byte size
// - will use fast SSE4.2 popcnt instruction if available on the CPU
function GetBitsCount(const Bits; Count: PtrInt): PtrInt;
/// pure pascal version of GetBitsCountPtrInt()
// - defined just for regression tests - call GetBitsCountPtrInt() instead
// - has optimized asm on x86_64 and i386
function GetBitsCountPas(value: PtrInt): PtrInt;
/// compute how many bits are set in a given pointer-sized integer
// - the PopCnt() intrinsic under FPC doesn't have any fallback on older CPUs,
// and default implementation is 5 times slower than our GetBitsCountPas() on x64
// - this redirected function will use fast SSE4.2 popcnt opcode, if available
var GetBitsCountPtrInt: function(value: PtrInt): PtrInt = GetBitsCountPas;
const
/// constant array used by GetAllBits() function (when inlined)
ALLBITS_CARDINAL: array[1..32] of Cardinal = (
1 shl 1-1, 1 shl 2-1, 1 shl 3-1, 1 shl 4-1, 1 shl 5-1, 1 shl 6-1,
1 shl 7-1, 1 shl 8-1, 1 shl 9-1, 1 shl 10-1, 1 shl 11-1, 1 shl 12-1,
1 shl 13-1, 1 shl 14-1, 1 shl 15-1, 1 shl 16-1, 1 shl 17-1, 1 shl 18-1,
1 shl 19-1, 1 shl 20-1, 1 shl 21-1, 1 shl 22-1, 1 shl 23-1, 1 shl 24-1,
1 shl 25-1, 1 shl 26-1, 1 shl 27-1, 1 shl 28-1, 1 shl 29-1, 1 shl 30-1,
$7fffffff, $ffffffff);
/// returns TRUE if all BitCount bits are set in the input 32-bit cardinal
function GetAllBits(Bits, BitCount: cardinal): boolean;
{$ifdef HASINLINE}inline;{$endif}
type
/// fast access to 8-bit integer bits
// - the compiler will generate bt/btr/bts opcodes
TBits8 = set of 0..7;
PBits8 = ^TBits8;
TBits8Array = array[0..maxInt-1] of TBits8;
/// fast access to 32-bit integer bits
// - the compiler will generate bt/btr/bts opcodes
TBits32 = set of 0..31;
PBits32 = ^TBits32;
/// fast access to 64-bit integer bits
// - the compiler will generate bt/btr/bts opcodes
// - as used by GetBit64/SetBit64/UnSetBit64
TBits64 = set of 0..63;
PBits64 = ^TBits64;
/// retrieve a particular bit status from a 64-bit integer bits (max aIndex is 63)
function GetBit64(const Bits: Int64; aIndex: PtrInt): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// set a particular bit into a 64-bit integer bits (max aIndex is 63)
procedure SetBit64(var Bits: Int64; aIndex: PtrInt);
{$ifdef HASINLINE}inline;{$endif}
/// unset/clear a particular bit into a 64-bit integer bits (max aIndex is 63)
procedure UnSetBit64(var Bits: Int64; aIndex: PtrInt);
{$ifdef HASINLINE}inline;{$endif}
/// logical OR of two memory buffers
// - will perform on all buffer bytes:
// ! Dest[i] := Dest[i] or Source[i];
procedure OrMemory(Dest,Source: PByteArray; size: PtrInt);
{$ifdef HASINLINE}inline;{$endif}
/// logical XOR of two memory buffers
// - will perform on all buffer bytes:
// ! Dest[i] := Dest[i] xor Source[i];
procedure XorMemory(Dest,Source: PByteArray; size: PtrInt); overload;
{$ifdef HASINLINE}inline;{$endif}
/// logical XOR of two memory buffers into a third
// - will perform on all buffer bytes:
// ! Dest[i] := Source1[i] xor Source2[i];
procedure XorMemory(Dest,Source1,Source2: PByteArray; size: PtrInt); overload;
{$ifdef HASINLINE}inline;{$endif}
/// logical AND of two memory buffers
// - will perform on all buffer bytes:
// ! Dest[i] := Dest[i] and Source[i];
procedure AndMemory(Dest,Source: PByteArray; size: PtrInt);
{$ifdef HASINLINE}inline;{$endif}
/// returns TRUE if all bytes equal zero
function IsZero(P: pointer; Length: integer): boolean; overload;
/// returns TRUE if all of a few bytes equal zero
// - to be called instead of IsZero() e.g. for 1..8 bytes
function IsZeroSmall(P: pointer; Length: PtrInt): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// returns TRUE if Value is nil or all supplied Values[] equal ''
function IsZero(const Values: TRawUTF8DynArray): boolean; overload;
/// returns TRUE if Value is nil or all supplied Values[] equal 0
function IsZero(const Values: TIntegerDynArray): boolean; overload;
/// returns TRUE if Value is nil or all supplied Values[] equal 0
function IsZero(const Values: TInt64DynArray): boolean; overload;
/// fill all entries of a supplied array of RawUTF8 with ''
procedure FillZero(var Values: TRawUTF8DynArray); overload;
/// fill all entries of a supplied array of 32-bit integers with 0
procedure FillZero(var Values: TIntegerDynArray); overload;
/// fill all entries of a supplied array of 64-bit integers with 0
procedure FillZero(var Values: TInt64DynArray); overload;
/// name the current thread so that it would be easily identified in the IDE debugger
procedure SetCurrentThreadName(const Format: RawUTF8; const Args: array of const);
/// name a thread so that it would be easily identified in the IDE debugger
// - you can force this function to do nothing by setting the NOSETTHREADNAME
// conditional, if you have issues with this feature when debugging your app
// - most meanling less characters (like 'TSQL') are trimmed to reduce the
// resulting length - which is convenient e.g. with POSIX truncation to 16 chars
procedure SetThreadName(ThreadID: TThreadID; const Format: RawUTF8;
const Args: array of const);
/// could be used to override SetThreadNameInternal()
// - under Linux/FPC, calls pthread_setname_np API which truncates to 16 chars
procedure SetThreadNameDefault(ThreadID: TThreadID; const Name: RawUTF8);
var
/// is overriden e.g. by mORMot.pas to log the thread name
SetThreadNameInternal: procedure(ThreadID: TThreadID; const Name: RawUTF8) = SetThreadNameDefault;
/// low-level wrapper to add a callback to a dynamic list of events
// - by default, you can assign only one callback to an Event: but by storing
// it as a dynamic array of events, you can use this wrapper to add one callback
// to this list of events
// - if the event was already registered, do nothing (i.e. won't call it twice)
// - since this function uses an unsafe typeless EventList parameter, you should
// not use it in high-level code, but only as wrapper within dedicated methods
// - will add Event to EventList[] unless Event is already registered
// - is used e.g. by TTextWriter as such:
// ! ...
// ! fEchos: array of TOnTextWriterEcho;
// ! ...
// ! procedure EchoAdd(const aEcho: TOnTextWriterEcho);
// ! ...
// ! procedure TTextWriter.EchoAdd(const aEcho: TOnTextWriterEcho);
// ! begin
// ! MultiEventAdd(fEchos,TMethod(aEcho));
// ! end;
// then callbacks are then executed as such:
// ! if fEchos<>nil then
// ! for i := 0 to length(fEchos)-1 do
// ! fEchos[i](self,fEchoBuf);
// - use MultiEventRemove() to un-register a callback from the list
function MultiEventAdd(var EventList; const Event: TMethod): boolean;
/// low-level wrapper to remove a callback from a dynamic list of events
// - by default, you can assign only one callback to an Event: but by storing
// it as a dynamic array of events, you can use this wrapper to remove one
// callback already registered by MultiEventAdd() to this list of events
// - since this function uses an unsafe typeless EventList parameter, you should
// not use it in high-level code, but only as wrapper within dedicated methods
// - is used e.g. by TTextWriter as such:
// ! ...
// ! fEchos: array of TOnTextWriterEcho;
// ! ...
// ! procedure EchoRemove(const aEcho: TOnTextWriterEcho);
// ! ...
// ! procedure TTextWriter.EchoRemove(const aEcho: TOnTextWriterEcho);
// ! begin
// ! MultiEventRemove(fEchos,TMethod(aEcho));
// ! end;
procedure MultiEventRemove(var EventList; const Event: TMethod); overload;
/// low-level wrapper to remove a callback from a dynamic list of events
// - same as the same overloaded procedure, but accepting an EventList[] index
// to identify the Event to be suppressed
procedure MultiEventRemove(var EventList; Index: Integer); overload;
/// low-level wrapper to check if a callback is in a dynamic list of events
// - by default, you can assign only one callback to an Event: but by storing
// it as a dynamic array of events, you can use this wrapper to check if
// a callback has already been registered to this list of events
// - used internally by MultiEventAdd() and MultiEventRemove() functions
function MultiEventFind(const EventList; const Event: TMethod): integer;
/// low-level wrapper to add one or several callbacks from another list of events
// - all events of the ToBeAddedList would be added to DestList
// - the list is not checked for duplicates
procedure MultiEventMerge(var DestList; const ToBeAddedList);
/// compare two TMethod instances
function EventEquals(const eventA,eventB): boolean;
{ ************ fast ISO-8601 types and conversion routines ***************** }
type
/// a type alias, which will be serialized as ISO-8601 with milliseconds
// - i.e. 'YYYY-MM-DD hh:mm:ss.sss' or 'YYYYMMDD hhmmss.sss' format
TDateTimeMS = type TDateTime;
/// a dynamic array of TDateTimeMS values
TDateTimeMSDynArray = array of TDateTimeMS;
PDateTimeMSDynArray = ^TDateTimeMSDynArray;
{$A-}
/// a simple way to store a date as Year/Month/Day
// - with no needed computation as with TDate/TUnixTime values
// - consider using TSynSystemTime if you need to handle both Date and Time
// - match the first 4 fields of TSynSystemTime - so PSynDate(@aSynSystemTime)^
// is safe to be used
// - DayOfWeek field is not handled by its methods by default, but could be
// filled on demand via ComputeDayOfWeek - making this record 64-bit long
// - some Delphi revisions have trouble with "object" as own method parameters
// (e.g. IsEqual) so we force to use "record" type if possible
{$ifdef USERECORDWITHMETHODS}TSynDate = record{$else}
TSynDate = object{$endif}
Year, Month, DayOfWeek, Day: word;
/// set all fields to 0
procedure Clear; {$ifdef HASINLINE}inline;{$endif}
/// set internal date to 9999-12-31
procedure SetMax; {$ifdef HASINLINE}inline;{$endif}
/// returns true if all fields are zero
function IsZero: boolean; {$ifdef HASINLINE}inline;{$endif}
/// try to parse a YYYY-MM-DD or YYYYMMDD ISO-8601 date from the supplied buffer
// - on success, move P^ just after the date, and return TRUE
function ParseFromText(var P: PUTF8Char): boolean; {$ifdef HASINLINE}inline;{$endif}
/// fill fields with the current UTC/local date, using a 8-16ms thread-safe cache
procedure FromNow(localtime: boolean=false);
/// fill fields with the supplied date
procedure FromDate(date: TDate);
/// returns true if all fields do match - ignoring DayOfWeek field value
function IsEqual({$ifdef FPC}constref{$else}const{$endif} another{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): boolean;
/// compare the stored value to a supplied value
// - returns <0 if the stored value is smaller than the supplied value,
// 0 if both are equals, and >0 if the stored value is bigger
// - DayOfWeek field value is not compared
function Compare({$ifdef FPC}constref{$else}const{$endif} another{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): integer;
{$ifdef HASINLINE}inline;{$endif}
/// fill the DayOfWeek field from the stored Year/Month/Day
// - by default, most methods will just store 0 in the DayOfWeek field
// - sunday is DayOfWeek 1, saturday is 7
procedure ComputeDayOfWeek;
/// convert the stored date into a Delphi TDate floating-point value
function ToDate: TDate; {$ifdef HASINLINE}inline;{$endif}
/// encode the stored date as ISO-8601 text
// - returns '' if the stored date is 0 (i.e. after Clear)
function ToText(Expanded: boolean=true): RawUTF8;
end;
/// store several dates as Year/Month/Day
TSynDateDynArray = array of TSynDate;
/// a pointer to a TSynDate instance
PSynDate = ^TSynDate;
/// a cross-platform and cross-compiler TSystemTime 128-bit structure
// - FPC's TSystemTime in datih.inc does NOT match Windows TSystemTime fields!
// - also used to store a Date/Time in TSynTimeZone internal structures, or
// for fast conversion from TDateTime to its ready-to-display members
// - DayOfWeek field is not handled by most methods by default (left as 0),
// but could be filled on demand via ComputeDayOfWeek into its 1..7 value
// - some Delphi revisions have trouble with "object" as own method parameters
// (e.g. IsEqual) so we force to use "record" type if possible
{$ifdef USERECORDWITHMETHODS}TSynSystemTime = record{$else}
TSynSystemTime = object{$endif}
public
Year, Month, DayOfWeek, Day,
Hour, Minute, Second, MilliSecond: word;
/// set all fields to 0
procedure Clear; {$ifdef HASINLINE}inline;{$endif}
/// returns true if all fields are zero
function IsZero: boolean; {$ifdef HASINLINE}inline;{$endif}
/// returns true if all fields do match
function IsEqual(const another{$ifndef DELPHI5OROLDER}: TSynSystemTime{$endif}): boolean;
/// returns true if date fields do match (ignoring DayOfWeek)
function IsDateEqual(const date{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): boolean;
/// used by TSynTimeZone
function EncodeForTimeChange(const aYear: word): TDateTime;
/// fill fields with the current UTC time, using a 8-16ms thread-safe cache
procedure FromNowUTC;
/// fill fields with the current Local time, using a 8-16ms thread-safe cache
procedure FromNowLocal;
/// fill fields from the given value - but not DayOfWeek
procedure FromDateTime(const dt: TDateTime);
/// fill Year/Month/Day fields from the given value - but not DayOfWeek
// - faster than the RTL DecodeDate() function
procedure FromDate(const dt: TDateTime);
/// fill Hour/Minute/Second/Millisecond fields from the given number of milliseconds
// - faster than the RTL DecodeTime() function
procedure FromMS(ms: PtrUInt);
/// fill Hour/Minute/Second/Millisecond fields from the given number of seconds
// - faster than the RTL DecodeTime() function
procedure FromSec(s: PtrUInt);
/// fill Hour/Minute/Second/Millisecond fields from the given TDateTime value
// - faster than the RTL DecodeTime() function
procedure FromTime(const dt: TDateTime);
/// fill Year/Month/Day and Hour/Minute/Second fields from the given ISO-8601 text
// - returns true on success
function FromText(const iso: RawUTF8): boolean;
/// encode the stored date/time as ISO-8601 text with Milliseconds
function ToText(Expanded: boolean=true; FirstTimeChar: AnsiChar='T'; const TZD: RawUTF8=''): RawUTF8;
/// append the stored date and time, in a log-friendly format
// - e.g. append '20110325 19241502' - with no trailing space nor tab
// - as called by TTextWriter.AddCurrentLogTime()
procedure AddLogTime(WR: TTextWriter);
/// append the stored date and time, in apache-like format, to a TTextWriter
// - e.g. append '19/Feb/2019:06:18:55 ' - including a trailing space
procedure AddNCSAText(WR: TTextWriter);
/// append the stored date and time, in apache-like format, to a memory buffer
// - e.g. append '19/Feb/2019:06:18:55 ' - including a trailing space
// - returns the number of chars added to P, i.e. always 21
function ToNCSAText(P: PUTF8Char): PtrInt;
/// convert the stored date and time to its text in HTTP-like format
// - i.e. "Tue, 15 Nov 1994 12:45:26 GMT" to be used as a value of
// "Date", "Expires" or "Last-Modified" HTTP header
// - handle UTC/GMT time zone by default
procedure ToHTTPDate(out text: RawUTF8; const tz: RawUTF8='GMT');
/// convert the stored date and time into its Iso-8601 text, with no Milliseconds
procedure ToIsoDateTime(out text: RawUTF8; const FirstTimeChar: AnsiChar='T');
/// convert the stored date into its Iso-8601 text with no time part
procedure ToIsoDate(out text: RawUTF8);
/// convert the stored time into its Iso-8601 text with no date part nor Milliseconds
procedure ToIsoTime(out text: RawUTF8; const FirstTimeChar: RawUTF8='T');
/// convert the stored time into a TDateTime
function ToDateTime: TDateTime;
/// copy Year/Month/DayOfWeek/Day fields to a TSynDate
procedure ToSynDate(out date: TSynDate); {$ifdef HASINLINE}inline;{$endif}
/// fill the DayOfWeek field from the stored Year/Month/Day
// - by default, most methods will just store 0 in the DayOfWeek field
// - sunday is DayOfWeek 1, saturday is 7
procedure ComputeDayOfWeek; {$ifdef HASINLINE}inline;{$endif}
/// add some 1..999 milliseconds to the stored time
// - not to be used for computation, but e.g. for fast AddLogTime generation
procedure IncrementMS(ms: integer);
end;
PSynSystemTime = ^TSynSystemTime;
{$A+}
/// fast bit-encoded date and time value
// - faster than Iso-8601 text and TDateTime, e.g. can be used as published
// property field in mORMot's TSQLRecord (see also TModTime and TCreateTime)
// - use internally for computation an abstract "year" of 16 months of 32 days
// of 32 hours of 64 minutes of 64 seconds - same as Iso8601ToTimeLog()
// - use TimeLogFromDateTime/TimeLogToDateTime/TimeLogNow functions, or
// type-cast any TTimeLog value with the TTimeLogBits memory structure for
// direct access to its bit-oriented content (or via PTimeLogBits pointer)
// - since TTimeLog type is bit-oriented, you can't just add or substract two
// TTimeLog values when doing date/time computation: use a TDateTime temporary
// conversion in such case:
// ! aTimestamp := TimeLogFromDateTime(IncDay(TimeLogToDateTime(aTimestamp)));
TTimeLog = type Int64;
/// dynamic array of TTimeLog
// - used by TDynArray JSON serialization to handle textual serialization
TTimeLogDynArray = array of TTimeLog;
/// pointer to a memory structure for direct access to a TTimeLog type value
PTimeLogBits = ^TTimeLogBits;
/// internal memory structure for direct access to a TTimeLog type value
// - most of the time, you should not use this object, but higher level
// TimeLogFromDateTime/TimeLogToDateTime/TimeLogNow/Iso8601ToTimeLog functions
// - since TTimeLogBits.Value is bit-oriented, you can't just add or substract
// two TTimeLog values when doing date/time computation: use a TDateTime
// temporary conversion in such case
// - TTimeLogBits.Value needs up to 40-bit precision, so features exact
// representation as JavaScript numbers (stored in a 52-bit mantissa)
TTimeLogBits = object
public
/// the bit-encoded value itself, which follows an abstract "year" of 16
// months of 32 days of 32 hours of 64 minutes of 64 seconds
// - bits 0..5 = Seconds (0..59)
// - bits 6..11 = Minutes (0..59)
// - bits 12..16 = Hours (0..23)
// - bits 17..21 = Day-1 (0..31)
// - bits 22..25 = Month-1 (0..11)
// - bits 26..40 = Year (0..9999)
Value: Int64;
/// extract the date and time content in Value into individual values
procedure Expand(out Date: TSynSystemTime);
/// convert to Iso-8601 encoded text, truncated to date/time only if needed
function Text(Expanded: boolean; FirstTimeChar: AnsiChar = 'T'): RawUTF8; overload;
/// convert to Iso-8601 encoded text, truncated to date/time only if needed
function Text(Dest: PUTF8Char; Expanded: boolean;
FirstTimeChar: AnsiChar = 'T'): integer; overload;
/// convert to Iso-8601 encoded text with date and time part
// - never truncate to date/time nor return '' as Text() does
function FullText(Expanded: boolean; FirstTimeChar: AnsiChar = 'T';
QuotedChar: AnsiChar = #0): RawUTF8; overload;
{$ifdef FPC}inline;{$endif} // URW1111 on Delphi 2010 and URW1136 on XE
/// convert to Iso-8601 encoded text with date and time part
// - never truncate to date/time or return '' as Text() does
function FullText(Dest: PUTF8Char; Expanded: boolean;
FirstTimeChar: AnsiChar = 'T'; QuotedChar: AnsiChar = #0): PUTF8Char; overload;
/// convert to ready-to-be displayed text
// - using i18nDateText global event, if set (e.g. by mORMoti18n.pas)
function i18nText: string;
/// convert to a Delphi Time
function ToTime: TDateTime;
/// convert to a Delphi Date
// - will return 0 if the stored value is not a valid date
function ToDate: TDateTime;
/// convert to a Delphi Date and Time
// - will return 0 if the stored value is not a valid date
function ToDateTime: TDateTime;
/// convert to a second-based c-encoded time (from Unix epoch 1/1/1970)
function ToUnixTime: TUnixTime;
/// convert to a millisecond-based c-encoded time (from Unix epoch 1/1/1970)
// - of course, milliseconds will be 0 due to TTimeLog second resolution
function ToUnixMSTime: TUnixMSTime;
/// fill Value from specified Date and Time
procedure From(Y,M,D, HH,MM,SS: cardinal); overload;
/// fill Value from specified TDateTime
procedure From(DateTime: TDateTime; DateOnly: Boolean=false); overload;
/// fill Value from specified File Date
procedure From(FileDate: integer); overload;
/// fill Value from Iso-8601 encoded text
procedure From(P: PUTF8Char; L: integer); overload; {$ifdef HASINLINE}inline;{$endif}
/// fill Value from Iso-8601 encoded text
procedure From(const S: RawUTF8); overload;
/// fill Value from specified Date/Time individual fields
procedure From(Time: PSynSystemTime); overload;
/// fill Value from second-based c-encoded time (from Unix epoch 1/1/1970)
procedure FromUnixTime(const UnixTime: TUnixTime);
/// fill Value from millisecond-based c-encoded time (from Unix epoch 1/1/1970)
// - of course, millisecond resolution will be lost during conversion
procedure FromUnixMSTime(const UnixMSTime: TUnixMSTime);
/// fill Value from current local system Date and Time
procedure FromNow;
/// fill Value from current UTC system Date and Time
// - FromNow uses local time: this function retrieves the system time
// expressed in Coordinated Universal Time (UTC)
procedure FromUTCTime;
/// get the year (e.g. 2015) of the TTimeLog value
function Year: Integer; {$ifdef HASINLINE}inline;{$endif}
/// get the month (1..12) of the TTimeLog value
function Month: Integer; {$ifdef HASINLINE}inline;{$endif}
/// get the day (1..31) of the TTimeLog value
function Day: Integer; {$ifdef HASINLINE}inline;{$endif}
/// get the hour (0..23) of the TTimeLog value
function Hour: integer; {$ifdef HASINLINE}inline;{$endif}
/// get the minute (0..59) of the TTimeLog value
function Minute: integer; {$ifdef HASINLINE}inline;{$endif}
/// get the second (0..59) of the TTimeLog value
function Second: integer; {$ifdef HASINLINE}inline;{$endif}
end;
/// get TTimeLog value from current local system date and time
// - handle TTimeLog bit-encoded Int64 format
function TimeLogNow: TTimeLog;
{$ifdef HASINLINE}inline;{$endif}
/// get TTimeLog value from current UTC system Date and Time
// - handle TTimeLog bit-encoded Int64 format
function TimeLogNowUTC: TTimeLog;
{$ifdef HASINLINE}inline;{$endif}
/// get TTimeLog value from a file date and time
// - handle TTimeLog bit-encoded Int64 format
function TimeLogFromFile(const FileName: TFileName): TTimeLog;
/// get TTimeLog value from a given Delphi date and time
// - handle TTimeLog bit-encoded Int64 format
// - just a wrapper around PTimeLogBits(@aTime)^.From()
// - we defined such a function since TTimeLogBits(aTimeLog).From() won't change
// the aTimeLog variable content
function TimeLogFromDateTime(const DateTime: TDateTime): TTimeLog;
{$ifdef HASINLINE}inline;{$endif}
/// get TTimeLog value from a given Unix seconds since epoch timestamp
// - handle TTimeLog bit-encoded Int64 format
// - just a wrapper around PTimeLogBits(@aTime)^.FromUnixTime()
function TimeLogFromUnixTime(const UnixTime: TUnixTime): TTimeLog;
{$ifdef HASINLINE}inline;{$endif}
/// Date/Time conversion from a TTimeLog value
// - handle TTimeLog bit-encoded Int64 format
// - just a wrapper around PTimeLogBits(@Timestamp)^.ToDateTime
// - we defined such a function since TTimeLogBits(aTimeLog).ToDateTime gives an
// internall compiler error on some Delphi IDE versions (e.g. Delphi 6)
function TimeLogToDateTime(const Timestamp: TTimeLog): TDateTime;
{$ifdef HASINLINE}inline;{$endif}
/// Unix seconds since epoch timestamp conversion from a TTimeLog value
// - handle TTimeLog bit-encoded Int64 format
// - just a wrapper around PTimeLogBits(@Timestamp)^.ToUnixTime
function TimeLogToUnixTime(const Timestamp: TTimeLog): TUnixTime;
{$ifdef HASINLINE}inline;{$endif}
/// convert a Iso8601 encoded string into a TTimeLog value
// - handle TTimeLog bit-encoded Int64 format
// - use this function only for fast comparison between two Iso8601 date/time
// - conversion is faster than Iso8601ToDateTime: use only binary integer math
// - ContainsNoTime optional pointer can be set to a boolean, which will be
// set according to the layout in P (e.g. TRUE for '2012-05-26')
// - returns 0 in case of invalid input string
function Iso8601ToTimeLogPUTF8Char(P: PUTF8Char; L: integer; ContainsNoTime: PBoolean=nil): TTimeLog;
/// convert a Iso8601 encoded string into a TTimeLog value
// - handle TTimeLog bit-encoded Int64 format
// - use this function only for fast comparison between two Iso8601 date/time
// - conversion is faster than Iso8601ToDateTime: use only binary integer math
function Iso8601ToTimeLog(const S: RawByteString): TTimeLog;
{$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif}
/// test if P^ contains a valid ISO-8601 text encoded value
// - calls internally Iso8601ToTimeLogPUTF8Char() and returns true if contains
// at least a valid year (YYYY)
function IsIso8601(P: PUTF8Char; L: integer): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// Date/Time conversion from ISO-8601
// - handle 'YYYYMMDDThhmmss' and 'YYYY-MM-DD hh:mm:ss' format
// - will also recognize '.sss' milliseconds suffix, if any
function Iso8601ToDateTime(const S: RawByteString): TDateTime; overload;
{$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif}
/// Date/Time conversion from ISO-8601
// - handle 'YYYYMMDDThhmmss' and 'YYYY-MM-DD hh:mm:ss' format
// - will also recognize '.sss' milliseconds suffix, if any
// - if L is left to default 0, it will be computed from StrLen(P)
function Iso8601ToDateTimePUTF8Char(P: PUTF8Char; L: integer=0): TDateTime;
{$ifdef HASINLINE}inline;{$endif}
/// Date/Time conversion from ISO-8601
// - handle 'YYYYMMDDThhmmss' and 'YYYY-MM-DD hh:mm:ss' format, with potentially
// shorten versions has handled by the ISO-8601 standard (e.g. 'YYYY')
// - will also recognize '.sss' milliseconds suffix, if any
// - if L is left to default 0, it will be computed from StrLen(P)
procedure Iso8601ToDateTimePUTF8CharVar(P: PUTF8Char; L: integer; var result: TDateTime);
/// Date/Time conversion from strict ISO-8601 content
// - recognize 'YYYY-MM-DDThh:mm:ss[.sss]' or 'YYYY-MM-DD' or 'Thh:mm:ss[.sss]'
// patterns, as e.g. generated by TTextWriter.AddDateTime() or RecordSaveJSON()
// - will also recognize '.sss' milliseconds suffix, if any
function Iso8601CheckAndDecode(P: PUTF8Char; L: integer; var Value: TDateTime): boolean;
/// Time conversion from ISO-8601 (with no Date part)
// - handle 'hhmmss' and 'hh:mm:ss' format
// - will also recognize '.sss' milliseconds suffix, if any
// - if L is left to default 0, it will be computed from StrLen(P)
function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer=0): TDateTime; overload;
{$ifdef HASINLINE}inline;{$endif}
/// Time conversion from ISO-8601 (with no Date part)
// - handle 'hhmmss' and 'hh:mm:ss' format
// - will also recognize '.sss' milliseconds suffix, if any
// - if L is left to default 0, it will be computed from StrLen(P)
procedure Iso8601ToTimePUTF8CharVar(P: PUTF8Char; L: integer; var result: TDateTime);
/// Time conversion from ISO-8601 (with no Date part)
// - recognize 'hhmmss' and 'hh:mm:ss' format into H,M,S variables
// - will also recognize '.sss' milliseconds suffix, if any, into MS
// - if L is left to default 0, it will be computed from StrLen(P)
function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer; var H,M,S,MS: cardinal): boolean; overload;
/// Date conversion from ISO-8601 (with no Time part)
// - recognize 'YYYY-MM-DD' and 'YYYYMMDD' format into Y,M,D variables
// - if L is left to default 0, it will be computed from StrLen(P)
function Iso8601ToDatePUTF8Char(P: PUTF8Char; L: integer; var Y,M,D: cardinal): boolean;
/// Interval date/time conversion from simple text
// - expected format does not match ISO-8601 Time intervals format, but Oracle
// interval litteral representation, i.e. '+/-D HH:MM:SS'
// - e.g. IntervalTextToDateTime('+0 06:03:20') will return 0.25231481481 and
// IntervalTextToDateTime('-20 06:03:20') -20.252314815
// - as a consequence, negative intervals will be written as TDateTime values:
// !DateTimeToIso8601Text(IntervalTextToDateTime('+0 06:03:20'))='T06:03:20'
// !DateTimeToIso8601Text(IntervalTextToDateTime('+1 06:03:20'))='1899-12-31T06:03:20'
// !DateTimeToIso8601Text(IntervalTextToDateTime('-2 06:03:20'))='1899-12-28T06:03:20'
function IntervalTextToDateTime(Text: PUTF8Char): TDateTime;
{$ifdef HASINLINE}inline;{$endif}
/// Interval date/time conversion from simple text
// - expected format does not match ISO-8601 Time intervals format, but Oracle
// interval litteral representation, i.e. '+/-D HH:MM:SS'
// - e.g. '+1 06:03:20' will return 1.25231481481
procedure IntervalTextToDateTimeVar(Text: PUTF8Char; var result: TDateTime);
/// basic Date/Time conversion into ISO-8601
// - use 'YYYYMMDDThhmmss' format if not Expanded
// - use 'YYYY-MM-DDThh:mm:ss' format if Expanded
// - if WithMS is TRUE, will append '.sss' for milliseconds resolution
// - if QuotedChar is not default #0, will (double) quote the resulted text
// - you may rather use DateTimeToIso8601Text() to handle 0 or date-only values
function DateTimeToIso8601(D: TDateTime; Expanded: boolean;
FirstChar: AnsiChar='T'; WithMS: boolean=false; QuotedChar: AnsiChar=#0): RawUTF8; overload;
/// basic Date/Time conversion into ISO-8601
// - use 'YYYYMMDDThhmmss' format if not Expanded
// - use 'YYYY-MM-DDThh:mm:ss' format if Expanded
// - if WithMS is TRUE, will append '.sss' for milliseconds resolution
// - if QuotedChar is not default #0, will (double) quote the resulted text
// - you may rather use DateTimeToIso8601Text() to handle 0 or date-only values
// - returns the number of chars written to P^ buffer
function DateTimeToIso8601(P: PUTF8Char; D: TDateTime; Expanded: boolean;
FirstChar: AnsiChar='T'; WithMS: boolean=false; QuotedChar: AnsiChar=#0): integer; overload;
/// basic Date conversion into ISO-8601
// - use 'YYYYMMDD' format if not Expanded
// - use 'YYYY-MM-DD' format if Expanded
function DateToIso8601(Date: TDateTime; Expanded: boolean): RawUTF8; overload;
/// basic Date conversion into ISO-8601
// - use 'YYYYMMDD' format if not Expanded
// - use 'YYYY-MM-DD' format if Expanded
function DateToIso8601(Y,M,D: cardinal; Expanded: boolean): RawUTF8; overload;
/// basic Date period conversion into ISO-8601
// - will convert an elapsed number of days as ISO-8601 text
// - use 'YYYYMMDD' format if not Expanded
// - use 'YYYY-MM-DD' format if Expanded
function DaysToIso8601(Days: cardinal; Expanded: boolean): RawUTF8;
/// basic Time conversion into ISO-8601
// - use 'Thhmmss' format if not Expanded
// - use 'Thh:mm:ss' format if Expanded
// - if WithMS is TRUE, will append '.sss' for milliseconds resolution
function TimeToIso8601(Time: TDateTime; Expanded: boolean; FirstChar: AnsiChar='T';
WithMS: boolean=false): RawUTF8;
/// Write a Date to P^ Ansi buffer
// - if Expanded is false, 'YYYYMMDD' date format is used
// - if Expanded is true, 'YYYY-MM-DD' date format is used
function DateToIso8601PChar(P: PUTF8Char; Expanded: boolean; Y,M,D: PtrUInt): PUTF8Char; overload;
/// convert a date into 'YYYY-MM-DD' date format
// - resulting text is compatible with all ISO-8601 functions
function DateToIso8601Text(Date: TDateTime): RawUTF8;
/// Write a Date/Time to P^ Ansi buffer
function DateToIso8601PChar(Date: TDateTime; P: PUTF8Char; Expanded: boolean): PUTF8Char; overload;
/// Write a TDateTime value, expanded as Iso-8601 encoded text into P^ Ansi buffer
// - if DT=0, returns ''
// - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD'
// - if DT contains only a time, returns the time encoded as 'Thh:mm:ss'
// - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss'
// - if WithMS is TRUE, will append '.sss' for milliseconds resolution
function DateTimeToIso8601ExpandedPChar(const Value: TDateTime; Dest: PUTF8Char;
FirstChar: AnsiChar='T'; WithMS: boolean=false): PUTF8Char;
/// write a TDateTime into strict ISO-8601 date and/or time text
// - if DT=0, returns ''
// - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD'
// - if DT contains only a time, returns the time encoded as 'Thh:mm:ss'
// - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss'
// - if WithMS is TRUE, will append '.sss' for milliseconds resolution
// - used e.g. by TPropInfo.GetValue() and TPropInfo.NormalizeValue() methods
function DateTimeToIso8601Text(DT: TDateTime; FirstChar: AnsiChar='T';
WithMS: boolean=false): RawUTF8;
{$ifdef HASINLINE}inline;{$endif}
/// write a TDateTime into strict ISO-8601 date and/or time text
// - if DT=0, returns ''
// - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD'
// - if DT contains only a time, returns the time encoded as 'Thh:mm:ss'
// - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss'
// - if WithMS is TRUE, will append '.sss' for milliseconds resolution
// - used e.g. by TPropInfo.GetValue() and TPropInfo.NormalizeValue() methods
procedure DateTimeToIso8601TextVar(DT: TDateTime; FirstChar: AnsiChar; var result: RawUTF8;
WithMS: boolean=false);
/// write a TDateTime into strict ISO-8601 date and/or time text
// - if DT=0, returns ''
// - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD'
// - if DT contains only a time, returns the time encoded as 'Thh:mm:ss'
// - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss'
// - if WithMS is TRUE, will append '.sss' for milliseconds resolution
// - used e.g. by TPropInfo.GetValue() and TPropInfo.NormalizeValue() methods
procedure DateTimeToIso8601StringVar(DT: TDateTime; FirstChar: AnsiChar; var result: string;
WithMS: boolean=false);
/// Write a Time to P^ Ansi buffer
// - if Expanded is false, 'Thhmmss' time format is used
// - if Expanded is true, 'Thh:mm:ss' time format is used
// - you can custom the first char in from of the resulting text time
// - if WithMS is TRUE, will append MS as '.sss' for milliseconds resolution
function TimeToIso8601PChar(P: PUTF8Char; Expanded: boolean; H,M,S,MS: PtrUInt;
FirstChar: AnsiChar = 'T'; WithMS: boolean=false): PUTF8Char; overload;
/// Write a Time to P^ Ansi buffer
// - if Expanded is false, 'Thhmmss' time format is used
// - if Expanded is true, 'Thh:mm:ss' time format is used
// - you can custom the first char in from of the resulting text time
// - if WithMS is TRUE, will append '.sss' for milliseconds resolution
function TimeToIso8601PChar(Time: TDateTime; P: PUTF8Char; Expanded: boolean;
FirstChar: AnsiChar = 'T'; WithMS: boolean=false): PUTF8Char; overload;
var
/// custom TTimeLog date to ready to be displayed text function
// - you can override this pointer in order to display the text according
// to your expected i18n settings
// - this callback will therefore be set by the mORMoti18n.pas unit
// - used e.g. by TTimeLogBits.i18nText and by TSQLTable.ExpandAsString()
// methods, i.e. TSQLTableToGrid.DrawCell()
i18nDateText: function(const Iso: TTimeLog): string = nil;
/// custom date to ready to be displayed text function
// - you can override this pointer in order to display the text according
// to your expected i18n settings
// - this callback will therefore be set by the mORMoti18n.pas unit
// - used e.g. by TSQLTable.ExpandAsString() method,
// i.e. TSQLTableToGrid.DrawCell()
i18nDateTimeText: function(const DateTime: TDateTime): string = nil;
/// wrapper calling global i18nDateTimeText() callback if set,
// or returning ISO-8601 standard layout on default
function DateTimeToi18n(const DateTime: TDateTime): string;
/// fast conversion of 2 digit characters into a 0..99 value
// - returns FALSE on success, TRUE if P^ is not correct
function Char2ToByte(P: PUTF8Char; out Value: Cardinal): Boolean;
/// fast conversion of 3 digit characters into a 0..9999 value
// - returns FALSE on success, TRUE if P^ is not correct
function Char3ToWord(P: PUTF8Char; out Value: Cardinal): Boolean;
/// fast conversion of 4 digit characters into a 0..9999 value
// - returns FALSE on success, TRUE if P^ is not correct
function Char4ToWord(P: PUTF8Char; out Value: Cardinal): Boolean;
/// our own fast version of the corresponding low-level RTL function
function TryEncodeDate(Year, Month, Day: cardinal; out Date: TDateTime): Boolean;
/// our own fast version of the corresponding low-level RTL function
function IsLeapYear(Year: cardinal): boolean;
{$ifdef HASINLINE} inline; {$endif}
/// retrieve the current Date, in the ISO 8601 layout, but expanded and
// ready to be displayed
function NowToString(Expanded: boolean=true; FirstTimeChar: AnsiChar=' '): RawUTF8;
/// retrieve the current UTC Date, in the ISO 8601 layout, but expanded and
// ready to be displayed
function NowUTCToString(Expanded: boolean=true; FirstTimeChar: AnsiChar=' '): RawUTF8;
/// convert some date/time to the ISO 8601 text layout, including milliseconds
// - i.e. 'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format
// - TZD is the ending time zone designator ('', 'Z' or '+hh:mm' or '-hh:mm')
// - see also TTextWriter.AddDateTimeMS method
function DateTimeMSToString(DateTime: TDateTime; Expanded: boolean=true;
FirstTimeChar: AnsiChar=' '; const TZD: RawUTF8='Z'): RawUTF8; overload;
/// convert some date/time to the ISO 8601 text layout, including milliseconds
// - i.e. 'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format
// - TZD is the ending time zone designator ('', 'Z' or '+hh:mm' or '-hh:mm')
// - see also TTextWriter.AddDateTimeMS method
function DateTimeMSToString(HH,MM,SS,MS,Y,M,D: cardinal; Expanded: boolean;
FirstTimeChar: AnsiChar=' '; const TZD: RawUTF8='Z'): RawUTF8; overload;
/// convert some date/time to the "HTTP-date" format as defined by RFC 7231
// - i.e. "Tue, 15 Nov 1994 12:45:26 GMT" to be used as a value of
// "Date", "Expires" or "Last-Modified" HTTP header
// - if you care about timezones Value must be converted to UTC first
// using TSynTimeZone.LocalToUtc, or tz should be properly set
function DateTimeToHTTPDate(dt: TDateTime; const tz: RawUTF8='GMT'): RawUTF8; overload;
/// convert some TDateTime to a small text layout, perfect e.g. for naming a local file
// - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting
// a date > 1999 (a current date would be fine)
function DateTimeToFileShort(const DateTime: TDateTime): TShort16; overload;
{$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell
/// convert some TDateTime to a small text layout, perfect e.g. for naming a local file
// - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting
// a date > 1999 (a current date would be fine)
procedure DateTimeToFileShort(const DateTime: TDateTime; out result: TShort16); overload;
/// retrieve the current Time (whithout Date), in the ISO 8601 layout
// - useful for direct on screen logging e.g.
function TimeToString: RawUTF8;
const
/// a contemporary, but elapsed, TUnixTime second-based value
// - corresponds to Thu, 08 Dec 2016 08:50:20 GMT
// - may be used to check for a valid just-generated Unix timestamp value
UNIXTIME_MINIMAL = 1481187020;
/// convert a second-based c-encoded time as TDateTime
// - i.e. number of seconds elapsed since Unix epoch 1/1/1970 into TDateTime
function UnixTimeToDateTime(const UnixTime: TUnixTime): TDateTime;
{$ifdef HASINLINE}inline;{$endif}
/// convert a TDateTime into a second-based c-encoded time
// - i.e. TDateTime into number of seconds elapsed since Unix epoch 1/1/1970
function DateTimeToUnixTime(const AValue: TDateTime): TUnixTime;
{$ifdef HASINLINE}inline;{$endif}
/// returns the current UTC date/time as a second-based c-encoded time
// - i.e. current number of seconds elapsed since Unix epoch 1/1/1970
// - faster than NowUTC or GetTickCount64, on Windows or Unix platforms
// (will use e.g. fast clock_gettime(CLOCK_REALTIME_COARSE) under Linux,
// or GetSystemTimeAsFileTime under Windows)
// - returns a 64-bit unsigned value, so is "Year2038bug" free
function UnixTimeUTC: TUnixTime;
{$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// convert some second-based c-encoded time (from Unix epoch 1/1/1970) to
// the ISO 8601 text layout
// - use 'YYYYMMDDThhmmss' format if not Expanded
// - use 'YYYY-MM-DDThh:mm:ss' format if Expanded
function UnixTimeToString(const UnixTime: TUnixTime; Expanded: boolean=true;
FirstTimeChar: AnsiChar='T'): RawUTF8;
/// convert some second-based c-encoded time (from Unix epoch 1/1/1970) to
// a small text layout, perfect e.g. for naming a local file
// - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting
// a date > 1999 (a current date would be fine)
procedure UnixTimeToFileShort(const UnixTime: TUnixTime; out result: TShort16); overload;
/// convert some second-based c-encoded time (from Unix epoch 1/1/1970) to
// a small text layout, perfect e.g. for naming a local file
// - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting
// a date > 1999 (a current date would be fine)
function UnixTimeToFileShort(const UnixTime: TUnixTime): TShort16; overload;
{$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell
/// convert some second-based c-encoded time to the ISO 8601 text layout, either
// as time or date elapsed period
// - this function won't add the Unix epoch 1/1/1970 offset to the timestamp
// - returns 'Thh:mm:ss' or 'YYYY-MM-DD' format, depending on the supplied value
function UnixTimePeriodToString(const UnixTime: TUnixTime; FirstTimeChar: AnsiChar='T'): RawUTF8;
/// returns the current UTC date/time as a millisecond-based c-encoded time
// - i.e. current number of milliseconds elapsed since Unix epoch 1/1/1970
// - faster and more accurate than NowUTC or GetTickCount64, on Windows or Unix
// - will use e.g. fast clock_gettime(CLOCK_REALTIME_COARSE) under Linux,
// or GetSystemTimeAsFileTime/GetSystemTimePreciseAsFileTime under Windows - the
// later being more accurate, but slightly slower than the former, so you may
// consider using UnixMSTimeUTCFast on Windows if its 10-16ms accuracy is enough
function UnixMSTimeUTC: TUnixMSTime;
{$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// returns the current UTC date/time as a millisecond-based c-encoded time
// - under Linux/POSIX, is the very same than UnixMSTimeUTC
// - under Windows 8+, will call GetSystemTimeAsFileTime instead of
// GetSystemTimePreciseAsFileTime, which has higher precision, but is slower
// - prefer it under Windows, if a dozen of ms resolution is enough for your task
function UnixMSTimeUTCFast: TUnixMSTime;
{$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// convert a millisecond-based c-encoded time (from Unix epoch 1/1/1970) as TDateTime
function UnixMSTimeToDateTime(const UnixMSTime: TUnixMSTime): TDateTime;
{$ifdef HASINLINE}inline;{$endif}
/// convert a TDateTime into a millisecond-based c-encoded time (from Unix epoch 1/1/1970)
// - if AValue is 0, will return 0 (since is likely to be an error constant)
function DateTimeToUnixMSTime(const AValue: TDateTime): TUnixMSTime;
{$ifdef HASINLINE}inline;{$endif}
/// convert some millisecond-based c-encoded time (from Unix epoch 1/1/1970) to
// the ISO 8601 text layout, including milliseconds
// - i.e. 'YYYY-MM-DDThh:mm:ss.sssZ' or 'YYYYMMDDThhmmss.sssZ' format
// - TZD is the ending time zone designator ('', 'Z' or '+hh:mm' or '-hh:mm')
function UnixMSTimeToString(const UnixMSTime: TUnixMSTime; Expanded: boolean=true;
FirstTimeChar: AnsiChar='T'; const TZD: RawUTF8=''): RawUTF8;
/// convert some milllisecond-based c-encoded time (from Unix epoch 1/1/1970) to
// a small text layout, trimming to the second resolution, perfect e.g. for
// naming a local file
// - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting
// a date > 1999 (a current date would be fine)
function UnixMSTimeToFileShort(const UnixMSTime: TUnixMSTime): TShort16;
{$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell
/// convert some millisecond-based c-encoded time to the ISO 8601 text layout,
// as time or date elapsed period
// - this function won't add the Unix epoch 1/1/1970 offset to the timestamp
// - returns 'Thh:mm:ss' or 'YYYY-MM-DD' format, depending on the supplied value
function UnixMSTimePeriodToString(const UnixMSTime: TUnixMSTime; FirstTimeChar: AnsiChar='T'): RawUTF8;
/// returns the current UTC system date and time
// - SysUtils.Now returns local time: this function returns the system time
// expressed in Coordinated Universal Time (UTC)
// - under Windows, will use GetSystemTimeAsFileTime() so will achieve about
// 16 ms of resolution
// - under POSIX, will call clock_gettime(CLOCK_REALTIME_COARSE)
function NowUTC: TDateTime;
{$ifndef ENHANCEDRTL}
{$ifndef LVCL} { don't define these twice }
var
/// these procedure type must be defined if a default system.pas is used
// - mORMoti18n.pas unit will hack default LoadResString() procedure
// - already defined in our Extended system.pas unit
// - needed with FPC, Delphi 2009 and up, i.e. when ENHANCEDRTL is not defined
// - expect generic "string" type, i.e. UnicodeString for Delphi 2009+
// - not needed with the LVCL framework (we should be on server side)
LoadResStringTranslate: procedure(var Text: string) = nil;
/// current LoadResString() cached entries count
// - i.e. resourcestring caching for faster use
// - used only if a default system.pas is used, not our Extended version
// - defined here, but resourcestring caching itself is implemented in the
// mORMoti18n.pas unit, if the ENHANCEDRTL conditional is not defined
CacheResCount: integer = -1;
{$endif}
{$endif}
type
/// a generic callback, which can be used to translate some text on the fly
// - maps procedure TLanguageFile.Translate(var English: string) signature
// as defined in mORMoti18n.pas
// - can be used e.g. for TSynMustache's {{"English text}} callback
TOnStringTranslate = procedure (var English: string) of object;
const
/// Rotate local log file if reached this size (1MB by default)
// - .log file will be save as .log.bak file
// - a new .log file is created
// - used by AppendToTextFile() and LogToTextFile() functions (not TSynLog)
MAXLOGSIZE = 1024*1024;
/// log a message to a local text file
// - the text file is located in the executable directory, and its name is
// simply the executable file name with the '.log' extension instead of '.exe'
// - format contains the current date and time, then the Msg on one line
// - date and time format used is 'YYYYMMDD hh:mm:ss (i.e. ISO-8601)'
procedure LogToTextFile(Msg: RawUTF8);
/// log a message to a local text file
// - this version expects the filename to be specified
// - format contains the current date and time, then the Msg on one line
// - date and time format used is 'YYYYMMDD hh:mm:ss'
procedure AppendToTextFile(aLine: RawUTF8; const aFileName: TFileName; aMaxSize: Int64=MAXLOGSIZE;
aUTCTimeStamp: boolean=false);
{ ************ fast low-level lookup types used by internal conversion routines }
{$ifndef ENHANCEDRTL}
{$ifndef LVCL} { don't define these const twice }
const
/// fast lookup table for converting any decimal number from
// 0 to 99 into their ASCII equivalence
// - our enhanced SysUtils.pas (normal and LVCL) contains the same array
TwoDigitLookup: packed array[0..99] of array[1..2] of AnsiChar =
('00','01','02','03','04','05','06','07','08','09',
'10','11','12','13','14','15','16','17','18','19',
'20','21','22','23','24','25','26','27','28','29',
'30','31','32','33','34','35','36','37','38','39',
'40','41','42','43','44','45','46','47','48','49',
'50','51','52','53','54','55','56','57','58','59',
'60','61','62','63','64','65','66','67','68','69',
'70','71','72','73','74','75','76','77','78','79',
'80','81','82','83','84','85','86','87','88','89',
'90','91','92','93','94','95','96','97','98','99');
{$endif}
{$endif}
var
/// fast lookup table for converting any decimal number from
// 0 to 99 into their ASCII ('0'..'9') equivalence
TwoDigitLookupW: packed array[0..99] of word absolute TwoDigitLookup;
/// fast lookup table for converting any decimal number from
// 0 to 99 into their byte digits (0..9) equivalence
// - used e.g. by DoubleToAscii() implementing Grisu algorithm
TwoDigitByteLookupW: packed array[0..99] of word;
type
/// char categories for text line/word/identifiers/uri parsing
TTextChar = set of (tcNot01013, tc1013, tcCtrlNotLF, tcCtrlNot0Comma,
tcWord, tcIdentifierFirstChar, tcIdentifier, tcURIUnreserved);
TTextCharSet = array[AnsiChar] of TTextChar;
PTextCharSet = ^TTextCharSet;
TTextByteSet = array[byte] of TTextChar;
PTextByteSet = ^TTextByteSet;
var
/// branch-less table used for text line/word/identifiers/uri parsing
TEXT_CHARS: TTextCharSet;
TEXT_BYTES: TTextByteSet absolute TEXT_CHARS;
{$M+} // to have existing RTTI for published properties
type
/// used to retrieve version information from any EXE
// - under Linux, all version numbers are set to 0 by default
// - you should not have to use this class directly, but via the
// ExeVersion global variable
TFileVersion = class
protected
fDetailed: string;
fFileName: TFileName;
fBuildDateTime: TDateTime;
/// change the version (not to be used in most cases)
procedure SetVersion(aMajor,aMinor,aRelease,aBuild: integer);
public
/// executable major version number
Major: Integer;
/// executable minor version number
Minor: Integer;
/// executable release version number
Release: Integer;
/// executable release build number
Build: Integer;
/// build year of this exe file
BuildYear: word;
/// version info of the exe file as '3.1'
// - return "string" type, i.e. UnicodeString for Delphi 2009+
Main: string;
/// associated CompanyName string version resource
// - only available on Windows - contains '' under Linux/POSIX
CompanyName: RawUTF8;
/// associated FileDescription string version resource
// - only available on Windows - contains '' under Linux/POSIX
FileDescription: RawUTF8;
/// associated FileVersion string version resource
// - only available on Windows - contains '' under Linux/POSIX
FileVersion: RawUTF8;
/// associated InternalName string version resource
// - only available on Windows - contains '' under Linux/POSIX
InternalName: RawUTF8;
/// associated LegalCopyright string version resource
// - only available on Windows - contains '' under Linux/POSIX
LegalCopyright: RawUTF8;
/// associated OriginalFileName string version resource
// - only available on Windows - contains '' under Linux/POSIX
OriginalFilename: RawUTF8;
/// associated ProductName string version resource
// - only available on Windows - contains '' under Linux/POSIX
ProductName: RawUTF8;
/// associated ProductVersion string version resource
// - only available on Windows - contains '' under Linux/POSIX
ProductVersion: RawUTF8;
/// associated Comments string version resource
// - only available on Windows - contains '' under Linux/POSIX
Comments: RawUTF8;
/// retrieve application version from exe file name
// - DefaultVersion32 is used if no information Version was included into
// the executable resources (on compilation time)
// - you should not have to use this constructor, but rather access the
// ExeVersion global variable
constructor Create(const aFileName: TFileName; aMajor: integer=0;
aMinor: integer=0; aRelease: integer=0; aBuild: integer=0);
/// retrieve the version as a 32-bit integer with Major.Minor.Release
// - following Major shl 16+Minor shl 8+Release bit pattern
function Version32: integer;
/// build date and time of this exe file, as plain text
function BuildDateTimeString: string;
/// version info of the exe file as '3.1.0.123' or ''
// - this method returns '' if Detailed is '0.0.0.0'
function DetailedOrVoid: string;
/// returns the version information of this exe file as text
// - includes FileName (without path), Detailed and BuildDateTime properties
// - e.g. 'myprogram.exe 3.1.0.123 (2016-06-14 19:07:55)'
function VersionInfo: RawUTF8;
/// returns a ready-to-use User-Agent header with exe name, version and OS
// - e.g. 'myprogram/3.1.0.123W32' for myprogram running on Win32
// - here OS_INITIAL[] character is used to identify the OS, with '32'
// appended on Win32 only (e.g. 'myprogram/3.1.0.2W', is for Win64)
function UserAgent: RawUTF8;
/// returns the version information of a specified exe file as text
// - includes FileName (without path), Detailed and BuildDateTime properties
// - e.g. 'myprogram.exe 3.1.0.123 2016-06-14 19:07:55'
class function GetVersionInfo(const aFileName: TFileName): RawUTF8;
published
/// version info of the exe file as '3.1.0.123'
// - return "string" type, i.e. UnicodeString for Delphi 2009+
// - under Linux, always return '0.0.0.0' if no custom version number
// has been defined
// - consider using DetailedOrVoid method if '0.0.0.0' is not expected
property Detailed: string read fDetailed write fDetailed;
/// build date and time of this exe file
property BuildDateTime: TDateTime read fBuildDateTime write fBuildDateTime;
end;
{$M-}
{$ifdef DELPHI6OROLDER}
// define some common constants not available prior to Delphi 7
const
HoursPerDay = 24;
MinsPerHour = 60;
SecsPerMin = 60;
MSecsPerSec = 1000;
MinsPerDay = HoursPerDay * MinsPerHour;
SecsPerDay = MinsPerDay * SecsPerMin;
MSecsPerDay = SecsPerDay * MSecsPerSec;
DateDelta = 693594;
UnixDateDelta = 25569;
/// GetFileVersion returns the most significant 32-bit of a file's binary
// version number
// - typically, this includes the major and minor version placed
// together in one 32-bit integer
// - generally does not include the release or build numbers
// - returns Cardinal(-1) in case of failure
function GetFileVersion(const FileName: TFileName): cardinal;
{$endif DELPHI6OROLDER}
type
/// the recognized operating systems
// - it will also recognize some Linux distributions
TOperatingSystem = (osUnknown, osWindows, osLinux, osOSX, osBSD, osPOSIX,
osArch, osAurox, osDebian, osFedora, osGentoo, osKnoppix, osMint, osMandrake,
osMandriva, osNovell, osUbuntu, osSlackware, osSolaris, osSuse, osSynology,
osTrustix, osClear, osUnited, osRedHat, osLFS, osOracle, osMageia, osCentOS,
osCloud, osXen, osAmazon, osCoreOS, osAlpine, osAndroid);
/// the recognized Windows versions
// - defined even outside MSWINDOWS to allow process e.g. from monitoring tools
TWindowsVersion = (
wUnknown, w2000, wXP, wXP_64, wServer2003, wServer2003_R2,
wVista, wVista_64, wServer2008, wServer2008_64,
wSeven, wSeven_64, wServer2008_R2, wServer2008_R2_64,
wEight, wEight_64, wServer2012, wServer2012_64,
wEightOne, wEightOne_64, wServer2012R2, wServer2012R2_64,
wTen, wTen_64, wServer2016, wServer2016_64,
wEleven, wEleven_64, wServer2019_64);
/// the running Operating System, encoded as a 32-bit integer
TOperatingSystemVersion = packed record
case os: TOperatingSystem of
osUnknown: (b: array[0..2] of byte);
osWindows: (win: TWindowsVersion);
osLinux: (utsrelease: array[0..2] of byte);
end;
const
/// the recognized Windows versions, as plain text
// - defined even outside MSWINDOWS to allow process e.g. from monitoring tools
WINDOWS_NAME: array[TWindowsVersion] of RawUTF8 = (
'', '2000', 'XP', 'XP 64bit', 'Server 2003', 'Server 2003 R2',
'Vista', 'Vista 64bit', 'Server 2008', 'Server 2008 64bit',
'7', '7 64bit', 'Server 2008 R2', 'Server 2008 R2 64bit',
'8', '8 64bit', 'Server 2012', 'Server 2012 64bit',
'8.1', '8.1 64bit', 'Server 2012 R2', 'Server 2012 R2 64bit',
'10', '10 64bit', 'Server 2016', 'Server 2016 64bit',
'11', '11 64bit', 'Server 2019 64bit');
/// the recognized Windows versions which are 32-bit
WINDOWS_32 = [w2000, wXP, wServer2003, wServer2003_R2, wVista, wServer2008,
wSeven, wServer2008_R2, wEight, wServer2012, wEightOne, wServer2012R2,
wTen, wServer2016, wEleven];
/// translate one operating system (and distribution) into a single character
// - may be used internally e.g. for a HTTP User-Agent header, as with
// TFileVersion.UserAgent
OS_INITIAL: array[TOperatingSystem] of AnsiChar =
('?', 'W', 'L', 'X', 'B', 'P', 'A', 'a', 'D', 'F', 'G', 'K', 'M', 'm',
'n', 'N', 'U', 'S', 's', 'u', 'Y', 'T', 'C', 't', 'R', 'l', 'O', 'G',
'c', 'd', 'x', 'Z', 'r', 'p', 'J'); // for Android ... J = Java VM
/// the operating systems items which actually are Linux distributions
OS_LINUX = [osLinux, osArch .. osAndroid];
/// the compiler family used
COMP_TEXT = {$ifdef FPC}'Fpc'{$else}'Delphi'{$endif};
/// the target Operating System used for compilation, as text
OS_TEXT = {$ifdef MSWINDOWS}'Win'{$else}{$ifdef DARWIN}'OSX'{$else}
{$ifdef BSD}'BSD'{$else}{$ifdef ANDROID}'Android'{$else}{$ifdef LINUX}'Linux'{$else}'Posix'
{$endif}{$endif}{$endif}{$endif}{$endif};
/// the CPU architecture used for compilation
CPU_ARCH_TEXT = {$ifdef CPUX86}'x86'{$else}{$ifdef CPUX64}'x64'{$else}
{$ifdef CPUARM}'arm'+{$else}
{$ifdef CPUAARCH64}'arm'+{$else}
{$ifdef CPUPOWERPC}'ppc'+{$else}
{$ifdef CPUSPARC}'sparc'+{$endif}{$endif}{$endif}{$endif}
{$ifdef CPU32}'32'{$else}'64'{$endif}{$endif}{$endif};
function ToText(os: TOperatingSystem): PShortString; overload;
function ToText(const osv: TOperatingSystemVersion): ShortString; overload;
function ToTextOS(osint32: integer): RawUTF8;
var
/// the target Operating System used for compilation, as TOperatingSystem
// - a specific Linux distribution may be detected instead of plain osLinux
OS_KIND: TOperatingSystem = {$ifdef MSWINDOWS}osWindows{$else}{$ifdef DARWIN}osOSX{$else}
{$ifdef BSD}osBSD{$else}{$ifdef Android}osAndroid{$else}{$ifdef LINUX}osLinux{$else}osPOSIX
{$endif}{$endif}{$endif}{$endif}{$endif};
/// the current Operating System version, as retrieved for the current process
// - contains e.g. 'Windows Seven 64 SP1 (6.1.7601)' or
// 'Ubuntu 16.04.5 LTS - Linux 3.13.0 110 generic#157 Ubuntu SMP Mon Feb 20 11:55:25 UTC 2017'
OSVersionText: RawUTF8;
/// some addition system information as text, e.g. 'Wine 1.1.5'
// - also always appended to OSVersionText high-level description
OSVersionInfoEx: RawUTF8;
/// some textual information about the current CPU
CpuInfoText: RawUTF8;
/// some textual information about the current computer hardware, from BIOS
BiosInfoText: RawUTF8;
/// the running Operating System
OSVersion32: TOperatingSystemVersion;
OSVersionInt32: integer absolute OSVersion32;
{$ifdef MSWINDOWS}
{$ifndef UNICODE}
type
/// low-level API structure, not defined in older Delphi versions
TOSVersionInfoEx = record
dwOSVersionInfoSize: DWORD;
dwMajorVersion: DWORD;
dwMinorVersion: DWORD;
dwBuildNumber: DWORD;
dwPlatformId: DWORD;
szCSDVersion: array[0..127] of char;
wServicePackMajor: WORD;
wServicePackMinor: WORD;
wSuiteMask: WORD;
wProductType: BYTE;
wReserved: BYTE;
end;
{$endif UNICODE}
var
/// is set to TRUE if the current process is a 32-bit image running under WOW64
// - WOW64 is the x86 emulator that allows 32-bit Windows-based applications
// to run seamlessly on 64-bit Windows
// - equals always FALSE if the current executable is a 64-bit image
IsWow64: boolean;
/// the current System information, as retrieved for the current process
// - under a WOW64 process, it will use the GetNativeSystemInfo() new API
// to retrieve the real top-most system information
// - note that the lpMinimumApplicationAddress field is replaced by a
// more optimistic/realistic value ($100000 instead of default $10000)
// - under BSD/Linux, only contain dwPageSize and dwNumberOfProcessors fields
SystemInfo: TSystemInfo;
/// the current Operating System information, as retrieved for the current process
OSVersionInfo: TOSVersionInfoEx;
/// the current Operating System version, as retrieved for the current process
OSVersion: TWindowsVersion;
/// this function can be used to create a GDI compatible window, able to
// receive Windows Messages for fast local communication
// - will return 0 on failure (window name already existing e.g.), or
// the created HWND handle on success
// - it will call the supplied message handler defined for a given Windows Message:
// for instance, define such a method in any object definition:
// ! procedure WMCopyData(var Msg : TWMCopyData); message WM_COPYDATA;
function CreateInternalWindow(const aWindowName: string; aObject: TObject): HWND;
/// delete the window resources used to receive Windows Messages
// - must be called for each CreateInternalWindow() function
// - both parameter values are then reset to ''/0
function ReleaseInternalWindow(var aWindowName: string; var aWindow: HWND): boolean;
/// under Windows 7 and later, will set an unique application-defined
// Application User Model ID (AppUserModelID) that identifies the current
// process to the taskbar
// - this identifier allows an application to group its associated processes
// and windows under a single taskbar button
// - value can have no more than 128 characters, cannot contain spaces, and
// each section should be camel-cased, as such:
// $ CompanyName.ProductName.SubProduct.VersionInformation
// CompanyName and ProductName should always be used, while the SubProduct and
// VersionInformation portions are optional and depend on the application's requirements
// - if the supplied text does not contain an '.', 'ID.ID' will be used
function SetAppUserModelID(const AppUserModelID: string): boolean;
var
/// the number of milliseconds that have elapsed since the system was started
// - compatibility function, to be implemented according to the running OS
// - will use the corresponding native API function under Vista+, or
// will emulate it for older Windows versions (XP)
// - warning: FPC's SysUtils.GetTickCount64 or TThread.GetTickCount64 don't
// handle properly 49 days wrapping under XP -> always use this safe version
GetTickCount64: function: Int64; stdcall;
/// returns the highest resolution possible UTC timestamp on this system
// - detects newer API available since Windows 8, or fallback to good old
// GetSystemTimeAsFileTime() which may have the resolution of the HW timer,
// i.e. typically around 16 ms
// - GetSystemTimeAsFileTime() is always faster, so is to be preferred
// if second resolution is enough (e.g. for UnixTimeUTC)
// - see http://www.windowstimestamp.com/description
GetSystemTimePreciseAsFileTime: procedure(var ft: TFILETIME); stdcall;
/// similar to Windows sleep() API call, to be truly cross-platform
// - it should have a millisecond resolution, and handle ms=0 as a switch to
// another pending thread, i.e. under Windows will call SwitchToThread API
procedure SleepHiRes(ms: cardinal);
/// low-level wrapper to get the 64-bit value from a TFileTime
// - as recommended by MSDN to avoid dword alignment issue
procedure FileTimeToInt64(const FT: TFileTime; out I64: Int64);
{$ifdef HASINLINE}inline;{$endif}
/// low-level conversion of a Windows 64-bit TFileTime into a Unix time seconds stamp
function FileTimeToUnixTime(const FT: TFileTime): TUnixTime;
/// low-level conversion of a Windows 64-bit TFileTime into a Unix time ms stamp
function FileTimeToUnixMSTime(const FT: TFileTime): TUnixMSTime;
type
/// direct access to the Windows Registry
// - could be used as alternative to TRegistry, which doesn't behave the same on
// all Delphi versions, and is enhanced on FPC (e.g. which supports REG_MULTI_SZ)
// - is also Unicode ready for text, using UTF-8 conversion on all compilers
TWinRegistry = object
public
/// the opened HKEY handle
key: HKEY;
/// start low-level read access to a Windows Registry node
// - on success (returned true), ReadClose() should be called
function ReadOpen(root: HKEY; const keyname: RawUTF8; closefirst: boolean=false): boolean;
/// finalize low-level read access to the Windows Registry after ReadOpen()
procedure Close;
/// low-level read a string from the Windows Registry after ReadOpen()
// - in respect to Delphi's TRegistry, will properly handle REG_MULTI_SZ
// (return the first value of the multi-list)
function ReadString(const entry: SynUnicode; andtrim: boolean=true): RawUTF8;
/// low-level read a Windows Registry content after ReadOpen()
// - works with any kind of key, but was designed for REG_BINARY
function ReadData(const entry: SynUnicode): RawByteString;
/// low-level read a Windows Registry 32-bit REG_DWORD value after ReadOpen()
function ReadDword(const entry: SynUnicode): cardinal;
/// low-level read a Windows Registry 64-bit REG_QWORD value after ReadOpen()
function ReadQword(const entry: SynUnicode): QWord;
/// low-level enumeration of all sub-entries names of a Windows Registry key
function ReadEnumEntries: TRawUTF8DynArray;
end;
{$else MSWINDOWS}
var
/// emulate only some used fields of Windows' TSystemInfo
SystemInfo: record
// retrieved from libc's getpagesize() - is expected to not be 0
dwPageSize: cardinal;
// retrieved from HW_NCPU (BSD) or /proc/cpuinfo (Linux)
dwNumberOfProcessors: cardinal;
// as returned by fpuname()
uts: UtsName;
// as from /etc/*-release
release: RawUTF8;
end;
{$ifdef KYLIX3}
/// compatibility function for Linux
function GetCurrentThreadID: TThreadID; cdecl;
external 'libpthread.so.0' name 'pthread_self';
/// overloaded function using open64() to allow 64-bit positions
function FileOpen(const FileName: string; Mode: LongWord): Integer;
{$endif}
/// compatibility function, to be implemented according to the running OS
// - expect more or less the same result as the homonymous Win32 API function,
// but usually with a better resolution (Windows has only around 10-16 ms)
// - will call the corresponding function in SynKylix.pas or SynFPCLinux.pas,
// using the very fast CLOCK_MONOTONIC_COARSE if available on the kernel
function GetTickCount64: Int64;
{$endif MSWINDOWS}
/// overloaded function optimized for one pass file reading
// - will use e.g. the FILE_FLAG_SEQUENTIAL_SCAN flag under Windows, as stated
// by http://blogs.msdn.com/b/oldnewthing/archive/2012/01/20/10258690.aspx
// - note: under XP, we observed ERROR_NO_SYSTEM_RESOURCES problems when calling
// FileRead() for chunks bigger than 32MB on files opened with this flag,
// so it would use regular FileOpen() on this deprecated OS
// - under POSIX, calls plain fpOpen(FileName,O_RDONLY) which would avoid a
// syscall to fpFlock() which is not needed here
// - is used e.g. by StringFromFile() and TSynMemoryStreamMapped.Create()
function FileOpenSequentialRead(const FileName: string): Integer;
{$ifdef HASINLINE}inline;{$endif}
/// returns a TFileStream optimized for one pass file reading
// - will use FileOpenSequentialRead(), i.e. FILE_FLAG_SEQUENTIAL_SCAN under
// Windows, and plain fpOpen(FileName, O_RDONLY) on POSIX
function FileStreamSequentialRead(const FileName: string): THandleStream;
/// check if the current timestamp, in ms, matched a given period
// - will compare the current GetTickCount64 to the supplied PreviousTix
// - returns TRUE if the Internal ms period was not elapsed
// - returns TRUE, and set PreviousTix, if the Interval ms period was elapsed
// - possible use case may be:
// !var Last: Int64;
// !...
// ! Last := GetTickCount64;
// ! repeat
// ! ...
// ! if Elapsed(Last,1000) then begin
// ! ... // do something every second
// ! end;
// ! until Terminated;
// !...
function Elapsed(var PreviousTix: Int64; Interval: Integer): Boolean;
/// thread-safe move of a 32-bit value using a simple Read-Copy-Update pattern
procedure RCU32(var src,dst);
/// thread-safe move of a 64-bit value using a simple Read-Copy-Update pattern
procedure RCU64(var src,dst);
/// thread-safe move of a 128-bit value using a simple Read-Copy-Update pattern
procedure RCU128(var src,dst);
/// thread-safe move of a pointer value using a simple Read-Copy-Update pattern
procedure RCUPtr(var src,dst);
/// thread-safe move of a memory buffer using a simple Read-Copy-Update pattern
procedure RCU(var src,dst; len: integer);
{$ifndef FPC} { FPC defines those functions as built-in }
/// compatibility function, to be implemented according to the running CPU
// - expect the same result as the homonymous Win32 API function
function InterlockedIncrement(var I: Integer): Integer;
{$ifdef PUREPASCAL}{$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif}{$endif}
/// compatibility function, to be implemented according to the running CPU
// - expect the same result as the homonymous Win32 API function
function InterlockedDecrement(var I: Integer): Integer;
{$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif}
{$endif FPC}
/// low-level string reference counter unprocess
// - caller should have tested that refcnt>=0
// - returns true if the managed variable should be released (i.e. refcnt was 1)
function StrCntDecFree(var refcnt: TStrCnt): boolean;
{$ifndef CPUINTEL} inline; {$endif}
/// low-level dynarray reference counter unprocess
// - caller should have tested that refcnt>=0
function DACntDecFree(var refcnt: TDACnt): boolean;
{$ifndef CPUINTEL} inline; {$endif}
type
/// stores some global information about the current executable and computer
TExeVersion = record
/// the main executable name, without any path nor extension
// - e.g. 'Test' for 'c:\pathto\Test.exe'
ProgramName: RawUTF8;
/// the main executable details, as used e.g. by TSynLog
// - e.g. 'C:\Dev\lib\SQLite3\exe\TestSQL3.exe 1.2.3.123 (2011-03-29 11:09:06)'
ProgramFullSpec: RawUTF8;
/// the main executable file name (including full path)
// - same as paramstr(0)
ProgramFileName: TFileName;
/// the main executable full path (excluding .exe file name)
// - same as ExtractFilePath(paramstr(0))
ProgramFilePath: TFileName;
/// the full path of the running executable or library
// - for an executable, same as paramstr(0)
// - for a library, will contain the whole .dll file name
InstanceFileName: TFileName;
/// the current executable version
Version: TFileVersion;
/// the current computer host name
Host: RawUTF8;
/// the current computer user name
User: RawUTF8;
/// some hash representation of this information
// - the very same executable on the very same computer run by the very
// same user will always have the same Hash value
// - is computed from the crc32c of this TExeVersion fields: c0 from
// Version32, CpuFeatures and Host, c1 from User, c2 from ProgramFullSpec
// and c3 from InstanceFileName
// - may be used as an entropy seed, or to identify a process execution
Hash: THash128Rec;
end;
var
/// global information about the current executable and computer
// - this structure is initialized in this unit's initialization block below
// - you can call SetExecutableVersion() with a custom version, if needed
ExeVersion: TExeVersion;
/// initialize ExeVersion global variable, supplying a custom version number
// - by default, the version numbers will be retrieved at startup from the
// executable itself (if it was included at build time)
// - but you can use this function to set any custom version numbers
procedure SetExecutableVersion(aMajor,aMinor,aRelease,aBuild: integer); overload;
/// initialize ExeVersion global variable, supplying the version as text
// - e.g. SetExecutableVersion('7.1.2.512');
procedure SetExecutableVersion(const aVersionText: RawUTF8); overload;
type
/// identify an operating system folder
TSystemPath = (
spCommonData, spUserData, spCommonDocuments, spUserDocuments, spTempFolder, spLog);
/// returns an operating system folder
// - will return the full path of a given kind of private or shared folder,
// depending on the underlying operating system
// - will use SHGetFolderPath and the corresponding CSIDL constant under Windows
// - under POSIX, will return $TMP/$TMPDIR folder for spTempFolder, ~/.cache/appname
// for spUserData, /var/log for spLog, or the $HOME folder
// - returned folder name contains the trailing path delimiter (\ or /)
function GetSystemPath(kind: TSystemPath): TFileName;
/// self-modifying code - change some memory buffer in the code segment
// - if Backup is not nil, it should point to a Size array of bytes, ready
// to contain the overridden code buffer, for further hook disabling
procedure PatchCode(Old,New: pointer; Size: integer; Backup: pointer=nil;
LeaveUnprotected: boolean=false);
/// self-modifying code - change one PtrUInt in the code segment
procedure PatchCodePtrUInt(Code: PPtrUInt; Value: PtrUInt;
LeaveUnprotected: boolean=false);
{$ifdef CPUINTEL}
type
/// small memory buffer used to backup a RedirectCode() redirection hook
TPatchCode = array[0..4] of byte;
/// pointer to a small memory buffer used to backup a RedirectCode() hook
PPatchCode = ^TPatchCode;
/// self-modifying code - add an asm JUMP to a redirected function
// - if Backup is not nil, it should point to a TPatchCode buffer, ready
// to contain the overridden code buffer, for further hook disabling
procedure RedirectCode(Func, RedirectFunc: Pointer; Backup: PPatchCode=nil);
/// self-modifying code - restore a code from its RedirectCode() backup
procedure RedirectCodeRestore(Func: pointer; const Backup: TPatchCode);
{$endif CPUINTEL}
type
/// to be used instead of TMemoryStream, for speed
// - allocates memory from Delphi heap (i.e. FastMM4/SynScaleMM)
// and not GlobalAlloc(), as was the case for oldest versions of Delphi
// - uses bigger growing size of the capacity
// - consider using TRawByteStringStream, as we do in our units
{$ifdef LVCL} // LVCL already use Delphi heap instead of GlobalAlloc()
THeapMemoryStream = TMemoryStream;
{$else}
{$ifdef FPC} // FPC already use heap instead of GlobalAlloc()
THeapMemoryStream = TMemoryStream;
{$else}
{$ifndef UNICODE} // old Delphi used GlobalAlloc()
THeapMemoryStream = class(TMemoryStream)
protected
function Realloc(var NewCapacity: longint): Pointer; override;
end;
{$else}
THeapMemoryStream = TMemoryStream;
{$endif}
{$endif}
{$endif}
var
/// a global "Garbage collector", for some classes instances which must
// live during whole main executable process
// - used to avoid any memory leak with e.g. 'class var RecordProps', i.e.
// some singleton or static objects
// - to be used, e.g. as:
// ! Version := TFileVersion.Create(InstanceFileName,DefaultVersion32);
// ! GarbageCollector.Add(Version);
// - see also GarbageCollectorFreeAndNil() as an alternative
GarbageCollector: TSynObjectList;
/// set to TRUE when the global "Garbage collector" are beeing freed
GarbageCollectorFreeing: boolean;
/// a global "Garbage collector" for some TObject global variables which must
// live during whole main executable process
// - this list expects a pointer to the TObject instance variable to be
// specified, and will be set to nil (like a FreeAndNil)
// - this may be useful when used when targetting Delphi IDE packages,
// to circumvent the bug of duplicated finalization of units, in the scope
// of global variables
// - to be used, e.g. as:
// ! if SynAnsiConvertList=nil then
// ! GarbageCollectorFreeAndNil(SynAnsiConvertList,TObjectList.Create);
procedure GarbageCollectorFreeAndNil(var InstanceVariable; Instance: TObject);
/// force the global "Garbage collector" list to be released immediately
// - this function is called in the finalization section of this unit
// - you should NEVER have to call this function, unless some specific cases
// (e.g. when using Delphi packages, just before releasing the package)
procedure GarbageCollectorFree;
/// enter a giant lock for thread-safe shared process
// - shall be protected as such:
// ! GlobalLock;
// ! try
// ! .... do something thread-safe but as short as possible
// ! finally
// ! GlobalUnLock;
// ! end;
// - you should better not use such a giant-lock, but an instance-dedicated
// critical section - these functions are just here to be convenient, for
// non time-critical process
procedure GlobalLock;
/// release the giant lock for thread-safe shared process
// - you should better not use such a giant-lock, but an instance-dedicated
// critical section - these functions are just here to be convenient, for
// non time-critical process
procedure GlobalUnLock;
var
/// JSON compatible representation of a boolean value, i.e. 'false' and 'true'
// - can be used when a RawUTF8 string is expected
BOOL_UTF8: array[boolean] of RawUTF8;
const
/// JSON compatible representation of a boolean value, i.e. 'false' and 'true'
// - can be used e.g. in logs, or anything accepting a shortstring
BOOL_STR: array[boolean] of string[7] = ('false','true');
/// can be used to append to most English nouns to form a plural
// - see also the Plural function
PLURAL_FORM: array[boolean] of RawUTF8 = ('','s');
/// write count number and append 's' (if needed) to form a plural English noun
// - for instance, Plural('row',100) returns '100 rows' with no heap allocation
function Plural(const itemname: shortstring; itemcount: cardinal): shortstring;
/// returns TRUE if the specified field name is either 'ID', either 'ROWID'
function IsRowID(FieldName: PUTF8Char): boolean;
{$ifdef HASINLINE}inline;{$endif} overload;
/// returns TRUE if the specified field name is either 'ID', either 'ROWID'
function IsRowID(FieldName: PUTF8Char; FieldLen: integer): boolean;
{$ifdef HASINLINE}inline;{$endif} overload;
/// returns TRUE if the specified field name is either 'ID', either 'ROWID'
function IsRowIDShort(const FieldName: shortstring): boolean;
{$ifdef HASINLINE}inline;{$endif} overload;
/// retrieve the next SQL-like identifier within the UTF-8 buffer
// - will also trim any space (or line feeds) and trailing ';'
// - any comment like '/*nocache*/' will be ignored
// - returns true if something was set to Prop
function GetNextFieldProp(var P: PUTF8Char; var Prop: RawUTF8): boolean;
/// retrieve the next identifier within the UTF-8 buffer on the same line
// - GetNextFieldProp() will just handle line feeds (and ';') as spaces - which
// is fine e.g. for SQL, but not for regular config files with name/value pairs
// - returns true if something was set to Prop
function GetNextFieldPropSameLine(var P: PUTF8Char; var Prop: ShortString): boolean;
{ ************ variant-based process, including JSON/BSON document content }
const
/// unsigned 64bit integer variant type
// - currently called varUInt64 in Delphi (not defined in older versions),
// and varQWord in FPC
varWord64 = 21;
/// this variant type will map the current SynUnicode type
// - depending on the compiler version
varSynUnicode = {$ifdef HASVARUSTRING}varUString{$else}varOleStr{$endif};
/// this variant type will map the current string type
// - depending on the compiler version
varNativeString = {$ifdef UNICODE}varUString{$else}varString{$endif};
{$ifdef HASINLINE}
/// overloaded function which can be properly inlined
procedure VarClear(var v: variant); inline;
{$endif HASINLINE}
/// same as Dest := TVarData(Source) for simple values
// - will return TRUE for all simple values after varByRef unreference, and
// copying the unreferenced Source value into Dest raw storage
// - will return FALSE for not varByRef values, or complex values (e.g. string)
function SetVariantUnRefSimpleValue(const Source: variant; var Dest: TVarData): boolean;
{$ifdef HASINLINE}inline;{$endif}
{$ifndef LVCL}
/// convert a raw binary buffer into a variant RawByteString varString
// - you can then use VariantToRawByteString() to retrieve the binary content
procedure RawByteStringToVariant(Data: PByte; DataLen: Integer; var Value: variant); overload;
/// convert a RawByteString content into a variant varString
// - you can then use VariantToRawByteString() to retrieve the binary content
procedure RawByteStringToVariant(const Data: RawByteString; var Value: variant); overload;
/// convert back a RawByteString from a variant
// - the supplied variant should have been created via a RawByteStringToVariant()
// function call
procedure VariantToRawByteString(const Value: variant; var Dest: RawByteString);
/// same as Value := Null, but slightly faster
procedure SetVariantNull(var Value: variant);
{$ifdef HASINLINE}inline;{$endif}
const
NullVarData: TVarData = (VType: varNull);
var
/// a slightly faster alternative to Variants.Null function
Null: variant absolute NullVarData;
{$endif LVCL}
/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster
// - we also discovered some issues with FPC's Variants unit, so this function
// may be used even in end-user cross-compiler code
function VarIsEmptyOrNull(const V: Variant): Boolean;
{$ifdef HASINLINE}inline;{$endif}
/// same as VarIsEmpty(PVariant(V)^) or VarIsEmpty(PVariant(V)^), but faster
// - we also discovered some issues with FPC's Variants unit, so this function
// may be used even in end-user cross-compiler code
function VarDataIsEmptyOrNull(VarData: pointer): Boolean;
{$ifdef HASINLINE}inline;{$endif}
/// fastcheck if a variant hold a value
// - varEmpty, varNull or a '' string would be considered as void
// - varBoolean=false or varDate=0 would be considered as void
// - a TDocVariantData with Count=0 would be considered as void
// - any other value (e.g. integer) would be considered as not void
function VarIsVoid(const V: Variant): boolean;
/// returns a supplied string as variant, or null if v is void ('')
function VarStringOrNull(const v: RawUTF8): variant;
type
TVarDataTypes = set of 0..255;
/// allow to check for a specific set of TVarData.VType
function VarIs(const V: Variant; const VTypes: TVarDataTypes): Boolean;
{$ifdef HASINLINE}inline;{$endif}
{$ifndef NOVARIANTS}
type
/// custom variant handler with easier/faster access of variant properties,
// and JSON serialization support
// - default GetProperty/SetProperty methods are called via some protected
// virtual IntGet/IntSet methods, with less overhead (to be overriden)
// - these kind of custom variants will be faster than the default
// TInvokeableVariantType for properties getter/setter, but you should
// manually register each type by calling SynRegisterCustomVariantType()
// - also feature custom JSON parsing, via TryJSONToVariant() protected method
TSynInvokeableVariantType = class(TInvokeableVariantType)
protected
{$ifndef FPC}
{$ifndef DELPHI6OROLDER}
/// our custom call backs do not want the function names to be uppercased
function FixupIdent(const AText: string): string; override;
{$endif}
{$endif}
/// override those two abstract methods for fast getter/setter implementation
function IntGet(var Dest: TVarData; const Instance: TVarData;
Name: PAnsiChar; NameLen: PtrInt): boolean; virtual;
function IntSet(const Instance, Value: TVarData;
Name: PAnsiChar; NameLen: PtrInt): boolean; virtual;
public
/// search of a registered custom variant type from its low-level VarType
// - will first compare with its own VarType for efficiency
function FindSynVariantType(aVarType: Word; out CustomType: TSynInvokeableVariantType): boolean;
/// customization of JSON parsing into variants
// - will be called by e.g. by VariantLoadJSON() or GetVariantFromJSON()
// with Options: PDocVariantOptions parameter not nil
// - this default implementation will always returns FALSE,
// meaning that the supplied JSON is not to be handled by this custom
// (abstract) variant type
// - this method could be overridden to identify any custom JSON content
// and convert it into a dedicated variant instance, then return TRUE
// - warning: should NOT modify JSON buffer in-place, unless it returns true
function TryJSONToVariant(var JSON: PUTF8Char; var Value: variant;
EndOfObject: PUTF8Char): boolean; virtual;
/// customization of variant into JSON serialization
procedure ToJSON(W: TTextWriter; const Value: variant; Escape: TTextWriterKind); overload; virtual;
/// retrieve the field/column value
// - this method will call protected IntGet abstract method
function GetProperty(var Dest: TVarData; const V: TVarData;
const Name: String): Boolean; override;
/// set the field/column value
// - this method will call protected IntSet abstract method
{$ifdef FPC_VARIANTSETVAR} // see http://mantis.freepascal.org/view.php?id=26773
function SetProperty(var V: TVarData; const Name: string;
const Value: TVarData): Boolean; override;
{$else}
function SetProperty(const V: TVarData; const Name: string;
const Value: TVarData): Boolean; override;
{$endif}
/// clear the content
// - this default implementation will set VType := varEmpty
// - override it if your custom type needs to manage its internal memory
procedure Clear(var V: TVarData); override;
/// copy two variant content
// - this default implementation will copy the TVarData memory
// - override it if your custom type needs to manage its internal structure
procedure Copy(var Dest: TVarData; const Source: TVarData;
const Indirect: Boolean); override;
/// copy two variant content by value
// - this default implementation will call the Copy() method
// - override it if your custom types may use a by reference copy pattern
procedure CopyByValue(var Dest: TVarData; const Source: TVarData); virtual;
/// this method will allow to look for dotted name spaces, e.g. 'parent.child'
// - should return Unassigned if the FullName does not match any value
// - will identify TDocVariant storage, or resolve and call the generic
// TSynInvokeableVariantType.IntGet() method until nested value match
procedure Lookup(var Dest: TVarData; const Instance: TVarData; FullName: PUTF8Char);
/// will check if the value is an array, and return the number of items
// - if the document is an array, will return the items count (0 meaning
// void array) - used e.g. by TSynMustacheContextVariant
// - this default implementation will return -1 (meaning this is not an array)
// - overridden method could implement it, e.g. for TDocVariant of kind dvArray
function IterateCount(const V: TVarData): integer; virtual;
/// allow to loop over an array document
// - Index should be in 0..IterateCount-1 range
// - this default implementation will do nothing
procedure Iterate(var Dest: TVarData; const V: TVarData; Index: integer); virtual;
/// returns TRUE if the supplied variant is of the exact custom type
function IsOfType(const V: variant): boolean;
{$ifdef HASINLINE}inline;{$endif}
end;
/// class-reference type (metaclass) of custom variant type definition
// - used by SynRegisterCustomVariantType() function
TSynInvokeableVariantTypeClass = class of TSynInvokeableVariantType;
/// register a custom variant type to handle properties
// - this will implement an internal mechanism used to bypass the default
// _DispInvoke() implementation in Variant.pas, to use a faster version
// - is called in case of TSynTableVariant, TDocVariant, TBSONVariant or
// TSQLDBRowVariant
function SynRegisterCustomVariantType(aClass: TSynInvokeableVariantTypeClass): TSynInvokeableVariantType;
/// same as Dest := Source, but copying by reference
// - i.e. VType is defined as varVariant or varByRef
// - for instance, it will be used for late binding of TDocVariant properties,
// to let following statements work as expected:
// ! V := _Json('{arr:[1,2]}');
// ! V.arr.Add(3); // will work, since V.arr will be returned by reference
// ! writeln(V); // will write '{"arr":[1,2,3]}'
procedure SetVariantByRef(const Source: Variant; var Dest: Variant);
/// same as Dest := Source, but copying by value
// - will unreference any varByRef content
// - will convert any string value into RawUTF8 (varString) for consistency
procedure SetVariantByValue(const Source: Variant; var Dest: Variant);
/// same as FillChar(Value^,SizeOf(TVarData),0)
// - so can be used for TVarData or Variant
// - it will set V.VType := varEmpty, so Value will be Unassigned
// - it won't call VarClear(variant(Value)): it should have been cleaned before
procedure ZeroFill(Value: PVarData); {$ifdef HASINLINE}inline;{$endif}
/// fill all bytes of the value's memory buffer with zeros, i.e. 'toto' -> #0#0#0#0
// - may be used to cleanup stack-allocated content
procedure FillZero(var value: variant); overload;
/// retrieve a variant value from variable-length buffer
// - matches TFileBufferWriter.Write()
// - how custom type variants are created can be defined via CustomVariantOptions
// - is just a wrapper around VariantLoad()
procedure FromVarVariant(var Source: PByte; var Value: variant;
CustomVariantOptions: PDocVariantOptions=nil); {$ifdef HASINLINE}inline;{$endif}
/// compute the number of bytes needed to save a Variant content
// using the VariantSave() function
// - will return 0 in case of an invalid (not handled) Variant type
function VariantSaveLength(const Value: variant): integer;
/// save a Variant content into a destination memory buffer
// - Dest must be at least VariantSaveLength() bytes long
// - will handle standard Variant types and custom types (serialized as JSON)
// - will return nil in case of an invalid (not handled) Variant type
// - will use a proprietary binary format, with some variable-length encoding
// of the string length
// - warning: will encode generic string fields as within the variant type
// itself: using this function between UNICODE and NOT UNICODE
// versions of Delphi, will propably fail - you have been warned!
function VariantSave(const Value: variant; Dest: PAnsiChar): PAnsiChar; overload;
/// save a Variant content into a binary buffer
// - will handle standard Variant types and custom types (serialized as JSON)
// - will return '' in case of an invalid (not handled) Variant type
// - just a wrapper around VariantSaveLength()+VariantSave()
// - warning: will encode generic string fields as within the variant type
// itself: using this function between UNICODE and NOT UNICODE
// versions of Delphi, will propably fail - you have been warned!
function VariantSave(const Value: variant): RawByteString; overload;
/// retrieve a variant value from our optimized binary serialization format
// - follow the data layout as used by RecordLoad() or VariantSave() function
// - return nil if the Source buffer is incorrect
// - in case of success, return the memory buffer pointer just after the
// read content
// - how custom type variants are created can be defined via CustomVariantOptions
function VariantLoad(var Value: variant; Source: PAnsiChar;
CustomVariantOptions: PDocVariantOptions; SourceMax: PAnsiChar=nil): PAnsiChar; overload;
/// retrieve a variant value from our optimized binary serialization format
// - follow the data layout as used by RecordLoad() or VariantSave() function
// - return varEmpty if the Source buffer is incorrect
// - just a wrapper around VariantLoad()
// - how custom type variants are created can be defined via CustomVariantOptions
function VariantLoad(const Bin: RawByteString;
CustomVariantOptions: PDocVariantOptions): variant; overload;
/// retrieve a variant value from a JSON number or string
// - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON)
// - will instantiate either an Integer, Int64, currency, double or string value
// (as RawUTF8), guessing the best numeric type according to the textual content,
// and string in all other cases, except TryCustomVariants points to some options
// (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or
// array, either encoded as strict-JSON (i.e. {..} or [..]), or with some
// extended (e.g. BSON) syntax
// - warning: the JSON buffer will be modified in-place during process - use
// a temporary copy or the overloaded functions with RawUTF8 parameter
// if you need to access it later
function VariantLoadJSON(var Value: variant; JSON: PUTF8Char;
EndOfObject: PUTF8Char=nil; TryCustomVariants: PDocVariantOptions=nil;
AllowDouble: boolean=false): PUTF8Char; overload;
/// retrieve a variant value from a JSON number or string
// - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON)
// - will instantiate either an Integer, Int64, currency, double or string value
// (as RawUTF8), guessing the best numeric type according to the textual content,
// and string in all other cases, except TryCustomVariants points to some options
// (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or
// array, either encoded as strict-JSON (i.e. {..} or [..]), or with some
// extended (e.g. BSON) syntax
// - this overloaded procedure will make a temporary copy before JSON parsing
// and return the variant as result
procedure VariantLoadJSON(var Value: Variant; const JSON: RawUTF8;
TryCustomVariants: PDocVariantOptions=nil; AllowDouble: boolean=false); overload;
/// retrieve a variant value from a JSON number or string
// - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON)
// - will instantiate either an Integer, Int64, currency, double or string value
// (as RawUTF8), guessing the best numeric type according to the textual content,
// and string in all other cases, except TryCustomVariants points to some options
// (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or
// array, either encoded as strict-JSON (i.e. {..} or [..]), or with some
// extended (e.g. BSON) syntax
// - this overloaded procedure will make a temporary copy before JSON parsing
// and return the variant as result
function VariantLoadJSON(const JSON: RawUTF8;
TryCustomVariants: PDocVariantOptions=nil; AllowDouble: boolean=false): variant; overload;
/// save a variant value into a JSON content
// - follows the TTextWriter.AddVariant() and VariantLoadJSON() format
// - is able to handle simple and custom variant types, for instance:
// ! VariantSaveJSON(1.5)='1.5'
// ! VariantSaveJSON('test')='"test"'
// ! o := _Json('{ BSON: [ "test", 5.05, 1986 ] }');
// ! VariantSaveJSON(o)='{"BSON":["test",5.05,1986]}'
// ! o := _Obj(['name','John','doc',_Obj(['one',1,'two',_Arr(['one',2])])]);
// ! VariantSaveJSON(o)='{"name":"John","doc":{"one":1,"two":["one",2]}}'
// - note that before Delphi 2009, any varString value is expected to be
// a RawUTF8 instance - which does make sense in the mORMot area
function VariantSaveJSON(const Value: variant; Escape: TTextWriterKind=twJSONEscape): RawUTF8; overload;
/// save a variant value into a JSON content
// - follows the TTextWriter.AddVariant() and VariantLoadJSON() format
// - is able to handle simple and custom variant types, for instance:
// ! VariantSaveJSON(1.5)='1.5'
// ! VariantSaveJSON('test')='"test"'
// ! o := _Json('{BSON: ["test", 5.05, 1986]}');
// ! VariantSaveJSON(o)='{"BSON":["test",5.05,1986]}'
// ! o := _Obj(['name','John','doc',_Obj(['one',1,'two',_Arr(['one',2])])]);
// ! VariantSaveJSON(o)='{"name":"John","doc":{"one":1,"two":["one",2]}}'
// - note that before Delphi 2009, any varString value is expected to be
// a RawUTF8 instance - which does make sense in the mORMot area
procedure VariantSaveJSON(const Value: variant; Escape: TTextWriterKind;
var result: RawUTF8); overload;
/// compute the number of chars needed to save a variant value into a JSON content
// - follows the TTextWriter.AddVariant() and VariantLoadJSON() format
// - this will be much faster than length(VariantSaveJSON()) for huge content
// - note that before Delphi 2009, any varString value is expected to be
// a RawUTF8 instance - which does make sense in the mORMot area
function VariantSaveJSONLength(const Value: variant; Escape: TTextWriterKind=twJSONEscape): integer;
/// low-level function to set a variant from an unescaped JSON number or string
// - expect the JSON input buffer to be already unescaped, e.g. by GetJSONField()
// - is called e.g. by function VariantLoadJSON()
// - will instantiate either a null, boolean, Integer, Int64, currency, double
// (if AllowDouble is true or dvoAllowDoubleValue is in TryCustomVariants^) or
// string value (as RawUTF8), guessing the best numeric type according to the textual content,
// and string in all other cases, except if TryCustomVariants points to some
// options (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known
// object or array, either encoded as strict-JSON (i.e. {..} or [..]),
// or with some extended (e.g. BSON) syntax
procedure GetVariantFromJSON(JSON: PUTF8Char; wasString: Boolean; var Value: variant;
TryCustomVariants: PDocVariantOptions=nil; AllowDouble: boolean=false);
/// low-level function to set a variant from an unescaped JSON non string
// - expect the JSON input buffer to be already unescaped, e.g. by GetJSONField(),
// and having returned wasString=TRUE (i.e. not surrounded by double quotes)
// - is called e.g. by function GetVariantFromJSON()
// - will recognize null, boolean, Integer, Int64, currency, double
// (if AllowDouble is true) input, then set Value and return TRUE
// - returns FALSE if the supplied input has no expected JSON format
function GetVariantFromNotStringJSON(JSON: PUTF8Char; var Value: TVarData;
AllowDouble: boolean): boolean;
/// identify either varInt64, varDouble, varCurrency types following JSON format
// - any non valid number is returned as varString
// - is used e.g. by GetVariantFromJSON() to guess the destination variant type
// - warning: supplied JSON is expected to be not nil
function TextToVariantNumberType(JSON: PUTF8Char): cardinal;
/// identify either varInt64 or varCurrency types following JSON format
// - this version won't return varDouble, i.e. won't handle more than 4 exact
// decimals (as varCurrency), nor scientific notation with exponent (1.314e10)
// - this will ensure that any incoming JSON will converted back with its exact
// textual representation, without digit truncation due to limited precision
// - any non valid number is returned as varString
// - is used e.g. by GetVariantFromJSON() to guess the destination variant type
// - warning: supplied JSON is expected to be not nil
function TextToVariantNumberTypeNoDouble(JSON: PUTF8Char): cardinal;
/// low-level function to set a numerical variant from an unescaped JSON number
// - returns TRUE if TextToVariantNumberType/TextToVariantNumberTypeNoDouble(JSON)
// identified it as a number and set Value to the corresponding content
// - returns FALSE if JSON is a string, or null/true/false
function GetNumericVariantFromJSON(JSON: PUTF8Char; var Value: TVarData;
AllowVarDouble: boolean): boolean;
/// convert the next CSV item from an UTF-8 encoded text buffer
// into a variant number or RawUTF8 varString
// - first try with GetNumericVariantFromJSON(), then fallback to RawUTF8ToVariant
// - is a wrapper around GetNextItem() + TextToVariant()
function GetNextItemToVariant(var P: PUTF8Char; out Value: Variant;
Sep: AnsiChar= ','; AllowDouble: boolean=true): boolean;
/// retrieve a variant value from a JSON buffer as per RFC 8259, RFC 7159, RFC 7158
// - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON)
// - will instantiate either an Integer, Int64, currency, double or string value
// (as RawUTF8), guessing the best numeric type according to the textual content,
// and string in all other cases, except TryCustomVariants points to some options
// (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or
// array, either encoded as strict-JSON (i.e. {..} or [..]), or with some
// extended (e.g. BSON) syntax
// - warning: the JSON buffer will be modified in-place during process - use
// a temporary copy or the overloaded functions with RawUTF8 parameter
// if you need to access it later
procedure JSONToVariantInPlace(var Value: Variant; JSON: PUTF8Char;
Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty];
AllowDouble: boolean=false);
/// retrieve a variant value from a JSON UTF-8 text as per RFC 8259, RFC 7159, RFC 7158
// - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON)
// - will instantiate either an Integer, Int64, currency, double or string value
// (as RawUTF8), guessing the best numeric type according to the textual content,
// and string in all other cases, except TryCustomVariants points to some options
// (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or
// array, either encoded as strict-JSON (i.e. {..} or [..]), or with some
// extended (e.g. BSON) syntax
// - this overloaded procedure will make a temporary copy before JSON parsing
// and return the variant as result
function JSONToVariant(const JSON: RawUTF8;
Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty];
AllowDouble: boolean=false): variant;
/// convert an UTF-8 encoded text buffer into a variant number or RawUTF8 varString
// - first try with GetNumericVariantFromJSON(), then fallback to RawUTF8ToVariant
procedure TextToVariant(const aValue: RawUTF8; AllowVarDouble: boolean;
out aDest: variant);
/// convert an UTF-8 encoded text buffer into a variant RawUTF8 varString
procedure RawUTF8ToVariant(Txt: PUTF8Char; TxtLen: integer; var Value: variant); overload;
/// convert an UTF-8 encoded string into a variant RawUTF8 varString
procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: variant); overload;
/// convert a FormatUTF8() UTF-8 encoded string into a variant RawUTF8 varString
procedure FormatUTF8ToVariant(const Fmt: RawUTF8; const Args: array of const; var Value: variant);
/// convert an UTF-8 encoded string into a variant RawUTF8 varString
function RawUTF8ToVariant(const Txt: RawUTF8): variant; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert an UTF-8 encoded text buffer into a variant RawUTF8 varString
// - this overloaded version expects a destination variant type (e.g. varString
// varOleStr / varUString) - if the type is not handled, will raise an
// EVariantTypeCastError
procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: TVarData;
ExpectedValueType: cardinal); overload;
/// convert an open array (const Args: array of const) argument to a variant
// - note that, due to a Delphi compiler limitation, cardinal values should be
// type-casted to Int64() (otherwise the integer mapped value will be converted)
procedure VarRecToVariant(const V: TVarRec; var result: variant); overload;
/// convert an open array (const Args: array of const) argument to a variant
// - note that, due to a Delphi compiler limitation, cardinal values should be
// type-casted to Int64() (otherwise the integer mapped value will be converted)
function VarRecToVariant(const V: TVarRec): variant; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert a variant to an open array (const Args: array of const) argument
// - will always map to a vtVariant kind of argument
procedure VariantToVarRec(const V: variant; var result: TVarRec);
{$ifdef HASINLINE}inline;{$endif}
/// convert a dynamic array of variants into its JSON serialization
// - will use a TDocVariantData temporary storage
function VariantDynArrayToJSON(const V: TVariantDynArray): RawUTF8;
/// convert a JSON array into a dynamic array of variants
// - will use a TDocVariantData temporary storage
function JSONToVariantDynArray(const JSON: RawUTF8): TVariantDynArray;
/// convert an open array list into a dynamic array of variants
// - will use a TDocVariantData temporary storage
function ValuesToVariantDynArray(const items: array of const): TVariantDynArray;
type
/// pointer to a TDocVariant storage
// - since variants may be stored by reference (i.e. as varByRef), it may
// be a good idea to use such a pointer via DocVariantData(aVariant)^ or
// _Safe(aVariant)^ instead of TDocVariantData(aVariant),
// if you are not sure how aVariant was allocated (may be not _Obj/_Json)
PDocVariantData = ^TDocVariantData;
/// a custom variant type used to store any JSON/BSON document-based content
// - i.e. name/value pairs for objects, or an array of values (including
// nested documents), stored in a TDocVariantData memory structure
// - you can use _Obj()/_ObjFast() _Arr()/_ArrFast() _Json()/_JsonFast() or
// _JsonFmt()/_JsonFastFmt() functions to create instances of such variants
// - property access may be done via late-binding - with some restrictions
// for older versions of FPC, e.g. allowing to write:
// ! TDocVariant.NewFast(aVariant);
// ! aVariant.Name := 'John';
// ! aVariant.Age := 35;
// ! writeln(aVariant.Name,' is ',aVariant.Age,' years old');
// - it also supports a small set of pseudo-properties or pseudo-methods:
// ! aVariant._Count = DocVariantData(aVariant).Count
// ! aVariant._Kind = ord(DocVariantData(aVariant).Kind)
// ! aVariant._JSON = DocVariantData(aVariant).JSON
// ! aVariant._(i) = DocVariantData(aVariant).Value[i]
// ! aVariant.Value(i) = DocVariantData(aVariant).Value[i]
// ! aVariant.Value(aName) = DocVariantData(aVariant).Value[aName]
// ! aVariant.Name(i) = DocVariantData(aVariant).Name[i]
// ! aVariant.Add(aItem) = DocVariantData(aVariant).AddItem(aItem)
// ! aVariant._ := aItem = DocVariantData(aVariant).AddItem(aItem)
// ! aVariant.Add(aName,aValue) = DocVariantData(aVariant).AddValue(aName,aValue)
// ! aVariant.Exists(aName) = DocVariantData(aVariant).GetValueIndex(aName)>=0
// ! aVariant.Delete(i) = DocVariantData(aVariant).Delete(i)
// ! aVariant.Delete(aName) = DocVariantData(aVariant).Delete(aName)
// ! aVariant.NameIndex(aName) = DocVariantData(aVariant).GetValueIndex(aName)
// - it features direct JSON serialization/unserialization, e.g.:
// ! assert(_Json('["one",2,3]')._JSON='["one",2,3]');
// - it features direct trans-typing into a string encoded as JSON, e.g.:
// ! assert(_Json('["one",2,3]')='["one",2,3]');
TDocVariant = class(TSynInvokeableVariantType)
protected
/// name and values interning are shared among all TDocVariantData instances
fInternNames, fInternValues: TRawUTF8Interning;
/// fast getter/setter implementation
function IntGet(var Dest: TVarData; const Instance: TVarData;
Name: PAnsiChar; NameLen: PtrInt): boolean; override;
function IntSet(const Instance, Value: TVarData; Name: PAnsiChar; NameLen: PtrInt): boolean; override;
public
/// initialize a variant instance to store some document-based content
// - by default, every internal value will be copied, so access of nested
// properties can be slow - if you expect the data to be read-only or not
// propagated into another place, set aOptions=[dvoValueCopiedByReference]
// will increase the process speed a lot
class procedure New(out aValue: variant;
aOptions: TDocVariantOptions=[]); overload;
{$ifdef HASINLINE}inline;{$endif}
/// initialize a variant instance to store per-reference document-based content
// - same as New(aValue,JSON_OPTIONS[true]);
// - to be used e.g. as
// !var v: variant;
// !begin
// ! TDocVariant.NewFast(v);
// ! ...
class procedure NewFast(out aValue: variant); overload;
{$ifdef HASINLINE}inline;{$endif}
/// ensure a variant is a TDocVariant instance
// - if aValue is not a TDocVariant, will create a new JSON_OPTIONS[true]
class procedure IsOfTypeOrNewFast(var aValue: variant);
/// initialize several variant instances to store document-based content
// - replace several calls to TDocVariantData.InitFast
// - to be used e.g. as
// !var v1,v2,v3: TDocVariantData;
// !begin
// ! TDocVariant.NewFast([@v1,@v2,@v3]);
// ! ...
class procedure NewFast(const aValues: array of PDocVariantData); overload;
/// initialize a variant instance to store some document-based content
// - you can use this function to create a variant, which can be nested into
// another document, e.g.:
// ! aVariant := TDocVariant.New;
// ! aVariant.id := 10;
// - by default, every internal value will be copied, so access of nested
// properties can be slow - if you expect the data to be read-only or not
// propagated into another place, set Options=[dvoValueCopiedByReference]
// will increase the process speed a lot
// - in practice, you should better use _Obj()/_ObjFast() _Arr()/_ArrFast()
// functions or TDocVariant.NewFast()
class function New(Options: TDocVariantOptions=[]): variant; overload;
{$ifdef HASINLINE}inline;{$endif}
/// initialize a variant instance to store some document-based object content
// - object will be initialized with data supplied two by two, as Name,Value
// pairs, e.g.
// ! aVariant := TDocVariant.NewObject(['name','John','year',1972]);
// which is the same as:
// ! TDocVariant.New(aVariant);
// ! TDocVariantData(aVariant).AddValue('name','John');
// ! TDocVariantData(aVariant).AddValue('year',1972);
// - by default, every internal value will be copied, so access of nested
// properties can be slow - if you expect the data to be read-only or not
// propagated into another place, set Options=[dvoValueCopiedByReference]
// will increase the process speed a lot
// - in practice, you should better use the function _Obj() which is a
// wrapper around this class method
class function NewObject(const NameValuePairs: array of const;
Options: TDocVariantOptions=[]): variant;
/// initialize a variant instance to store some document-based array content
// - array will be initialized with data supplied as parameters, e.g.
// ! aVariant := TDocVariant.NewArray(['one',2,3.0]);
// which is the same as:
// ! TDocVariant.New(aVariant);
// ! TDocVariantData(aVariant).AddItem('one');
// ! TDocVariantData(aVariant).AddItem(2);
// ! TDocVariantData(aVariant).AddItem(3.0);
// - by default, every internal value will be copied, so access of nested
// properties can be slow - if you expect the data to be read-only or not
// propagated into another place, set aOptions=[dvoValueCopiedByReference]
// will increase the process speed a lot
// - in practice, you should better use the function _Arr() which is a
// wrapper around this class method
class function NewArray(const Items: array of const;
Options: TDocVariantOptions=[]): variant; overload;
/// initialize a variant instance to store some document-based array content
// - array will be initialized with data supplied dynamic array of variants
class function NewArray(const Items: TVariantDynArray;
Options: TDocVariantOptions=[]): variant; overload;
/// initialize a variant instance to store some document-based object content
// from a supplied (extended) JSON content
// - in addition to the JSON RFC specification strict mode, this method will
// handle some BSON-like extensions, e.g. unquoted field names
// - a private copy of the incoming JSON buffer will be used, then
// it will call the TDocVariantData.InitJSONInPlace() method
// - to be used e.g. as:
// ! var V: variant;
// ! begin
// ! V := TDocVariant.NewJSON('{"id":10,"doc":{"name":"John","birthyear":1972}}');
// ! assert(V.id=10);
// ! assert(V.doc.name='John');
// ! assert(V.doc.birthYear=1972);
// ! // and also some pseudo-properties:
// ! assert(V._count=2);
// ! assert(V.doc._kind=ord(dvObject));
// - or with a JSON array:
// ! V := TDocVariant.NewJSON('["one",2,3]');
// ! assert(V._kind=ord(dvArray));
// ! for i := 0 to V._count-1 do
// ! writeln(V._(i));
// - by default, every internal value will be copied, so access of nested
// properties can be slow - if you expect the data to be read-only or not
// propagated into another place, add dvoValueCopiedByReference in Options
// will increase the process speed a lot
// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency
// - in practice, you should better use the function _Json()/_JsonFast()
// which are handy wrappers around this class method
class function NewJSON(const JSON: RawUTF8;
Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant;
{$ifdef HASINLINE}inline;{$endif}
/// initialize a variant instance to store some document-based object content
// from a supplied existing TDocVariant instance
// - use it on a value returned as varByRef (e.g. by _() pseudo-method),
// to ensure the returned variant will behave as a stand-alone value
// - for instance, the following:
// ! oSeasons := TDocVariant.NewUnique(o.Seasons);
// is the same as:
// ! oSeasons := o.Seasons;
// ! _Unique(oSeasons);
// or even:
// ! oSeasons := _Copy(o.Seasons);
class function NewUnique(const SourceDocVariant: variant;
Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant;
{$ifdef HASINLINE}inline;{$endif}
/// will return the unique element of a TDocVariant array or a default
// - if the value is a dvArray with one single item, it will this value
// - if the value is not a TDocVariant nor a dvArray with one single item,
// it wil return the default value
class procedure GetSingleOrDefault(const docVariantArray, default: variant;
var result: variant);
/// finalize the stored information
destructor Destroy; override;
/// used by dvoInternNames for string interning of all Names[] values
function InternNames: TRawUTF8Interning; {$ifdef HASINLINE}inline;{$endif}
/// used by dvoInternValues for string interning of all RawUTF8 Values[]
function InternValues: TRawUTF8Interning; {$ifdef HASINLINE}inline;{$endif}
// this implementation will write the content as JSON object or array
procedure ToJSON(W: TTextWriter; const Value: variant; Escape: TTextWriterKind); override;
/// will check if the value is an array, and return the number of items
// - if the document is an array, will return the items count (0 meaning
// void array) - used e.g. by TSynMustacheContextVariant
// - this overridden method will implement it for dvArray instance kind
function IterateCount(const V: TVarData): integer; override;
/// allow to loop over an array document
// - Index should be in 0..IterateCount-1 range
// - this default implementation will do handle dvArray instance kind
procedure Iterate(var Dest: TVarData; const V: TVarData; Index: integer); override;
/// low-level callback to access internal pseudo-methods
// - mainly the _(Index: integer): variant method to retrieve an item
// if the document is an array
function DoFunction(var Dest: TVarData; const V: TVarData;
const Name: string; const Arguments: TVarDataArray): Boolean; override;
/// low-level callback to clear the content
procedure Clear(var V: TVarData); override;
/// low-level callback to copy two variant content
// - such copy will by default be done by-value, for safety
// - if you are sure you will use the variants as read-only, you can set
// the dvoValueCopiedByReference Option to use faster by-reference copy
procedure Copy(var Dest: TVarData; const Source: TVarData;
const Indirect: Boolean); override;
/// copy two variant content by value
// - overridden method since instance may use a by-reference copy pattern
procedure CopyByValue(var Dest: TVarData; const Source: TVarData); override;
/// handle type conversion
// - only types processed by now are string/OleStr/UnicodeString/date
procedure Cast(var Dest: TVarData; const Source: TVarData); override;
/// handle type conversion
// - only types processed by now are string/OleStr/UnicodeString/date
procedure CastTo(var Dest: TVarData; const Source: TVarData;
const AVarType: TVarType); override;
/// compare two variant values
// - it uses case-sensitive text comparison of the JSON representation
// of each variant (including TDocVariant instances)
procedure Compare(const Left, Right: TVarData;
var Relationship: TVarCompareResult); override;
end;
/// define the TDocVariant storage layout
// - if it has one or more named properties, it is a dvObject
// - if it has no name property, it is a dvArray
TDocVariantKind = (dvUndefined, dvObject, dvArray);
/// method used by TDocVariantData.ReduceAsArray to filter each object
// - should return TRUE if the item match the expectations
TOnReducePerItem = function(Item: PDocVariantData): boolean of object;
/// method used by TDocVariantData.ReduceAsArray to filter each object
// - should return TRUE if the item match the expectations
TOnReducePerValue = function(const Value: variant): boolean of object;
{$A-} { packet object not allowed since Delphi 2009 :( }
/// memory structure used for TDocVariant storage of any JSON/BSON
// document-based content as variant
// - i.e. name/value pairs for objects, or an array of values (including
// nested documents)
// - you can use _Obj()/_ObjFast() _Arr()/_ArrFast() _Json()/_JsonFast() or
// _JsonFmt()/_JsonFastFmt() functions to create instances of such variants
// - you can transtype such an allocated variant into TDocVariantData
// to access directly its internals (like Count or Values[]/Names[]):
// ! aVariantObject := TDocVariant.NewObject(['name','John','year',1972]);
// ! aVariantObject := _ObjFast(['name','John','year',1972]);
// ! with _Safe(aVariantObject)^ do
// ! for i := 0 to Count-1 do
// ! writeln(Names[i],'=',Values[i]); // for an object
// ! aVariantArray := TDocVariant.NewArray(['one',2,3.0]);
// ! aVariantArray := _JsonFast('["one",2,3.0]');
// ! with _Safe(aVariantArray)^ do
// ! for i := 0 to Count-1 do
// ! writeln(Values[i]); // for an array
// - use "with _Safe(...)^ do" and not "with TDocVariantData(...) do" as the
// former will handle internal variant redirection (varByRef), e.g. from late
// binding or assigned another TDocVariant
// - Delphi "object" is buggy on stack -> also defined as record with methods
{$ifdef USERECORDWITHMETHODS}TDocVariantData = record
{$else}TDocVariantData = object {$endif}
private
VType: TVarType;
VOptions: TDocVariantOptions;
(* this structure uses all TVarData available space: no filler needed!
{$HINTS OFF} // does not complain if Filler is declared but never used
Filler: array[1..SizeOf(TVarData)-SizeOf(TVarType)-SizeOf(TDocVariantOptions)-
SizeOf(TDocVariantKind)-SizeOf(TRawUTF8DynArray)-SizeOf(TVariantDynArray)-
SizeOf(integer)] of byte;
{$HINTS ON} *)
VName: TRawUTF8DynArray;
VValue: TVariantDynArray;
VCount: integer;
// retrieve the value as varByRef
function GetValueOrItem(const aNameOrIndex: variant): variant;
procedure SetValueOrItem(const aNameOrIndex, aValue: variant);
function GetKind: TDocVariantKind; {$ifdef HASINLINE}inline;{$endif}
procedure SetOptions(const opt: TDocVariantOptions); // keep dvoIsObject/Array
{$ifdef HASINLINE}inline;{$endif}
procedure SetCapacity(aValue: integer);
function GetCapacity: integer;
{$ifdef HASINLINE}inline;{$endif}
// implement U[] I[] B[] D[] O[] O_[] A[] A_[] _[] properties
function GetOrAddIndexByName(const aName: RawUTF8): integer;
{$ifdef HASINLINE}inline;{$endif}
function GetOrAddPVariantByName(const aName: RawUTF8): PVariant;
{$ifdef HASINLINE}inline;{$endif}
function GetPVariantByName(const aName: RawUTF8): PVariant;
function GetRawUTF8ByName(const aName: RawUTF8): RawUTF8;
procedure SetRawUTF8ByName(const aName, aValue: RawUTF8);
function GetStringByName(const aName: RawUTF8): string;
procedure SetStringByName(const aName: RawUTF8; const aValue: string);
function GetInt64ByName(const aName: RawUTF8): Int64;
procedure SetInt64ByName(const aName: RawUTF8; const aValue: Int64);
function GetBooleanByName(const aName: RawUTF8): Boolean;
procedure SetBooleanByName(const aName: RawUTF8; aValue: Boolean);
function GetDoubleByName(const aName: RawUTF8): Double;
procedure SetDoubleByName(const aName: RawUTF8; const aValue: Double);
function GetDocVariantExistingByName(const aName: RawUTF8;
aNotMatchingKind: TDocVariantKind): PDocVariantData;
function GetObjectExistingByName(const aName: RawUTF8): PDocVariantData;
function GetDocVariantOrAddByName(const aName: RawUTF8;
aKind: TDocVariantKind): PDocVariantData;
function GetObjectOrAddByName(const aName: RawUTF8): PDocVariantData;
function GetArrayExistingByName(const aName: RawUTF8): PDocVariantData;
function GetArrayOrAddByName(const aName: RawUTF8): PDocVariantData;
function GetAsDocVariantByIndex(aIndex: integer): PDocVariantData;
public
/// initialize a TDocVariantData to store some document-based content
// - can be used with a stack-allocated TDocVariantData variable:
// !var Doc: TDocVariantData; // stack-allocated variable
// !begin
// ! Doc.Init;
// ! Doc.AddValue('name','John');
// ! assert(Doc.Value['name']='John');
// ! assert(variant(Doc).name='John');
// !end;
// - if you call Init*() methods in a row, ensure you call Clear in-between
procedure Init(aOptions: TDocVariantOptions=[]; aKind: TDocVariantKind=dvUndefined);
/// initialize a TDocVariantData to store per-reference document-based content
// - same as Doc.Init(JSON_OPTIONS[true]);
// - can be used with a stack-allocated TDocVariantData variable:
// !var Doc: TDocVariantData; // stack-allocated variable
// !begin
// ! Doc.InitFast;
// ! Doc.AddValue('name','John');
// ! assert(Doc.Value['name']='John');
// ! assert(variant(Doc).name='John');
// !end;
// - see also TDocVariant.NewFast() if you want to initialize several
// TDocVariantData variable instances at once
// - if you call Init*() methods in a row, ensure you call Clear in-between
procedure InitFast; overload;
/// initialize a TDocVariantData to store per-reference document-based content
// - this overloaded method allows to specify an estimation of how many
// properties or items this aKind document would contain
procedure InitFast(InitialCapacity: integer; aKind: TDocVariantKind); overload;
/// initialize a TDocVariantData to store document-based object content
// - object will be initialized with data supplied two by two, as Name,Value
// pairs, e.g.
// !var Doc: TDocVariantData; // stack-allocated variable
// !begin
// ! Doc.InitObject(['name','John','year',1972]);
// which is the same as:
// ! var Doc: TDocVariantData;
// !begin
// ! Doc.Init;
// ! Doc.AddValue('name','John');
// ! Doc.AddValue('year',1972);
// - this method is called e.g. by _Obj() and _ObjFast() global functions
// - if you call Init*() methods in a row, ensure you call Clear in-between
procedure InitObject(const NameValuePairs: array of const;
aOptions: TDocVariantOptions=[]);
/// initialize a variant instance to store some document-based array content
// - array will be initialized with data supplied as parameters, e.g.
// !var Doc: TDocVariantData; // stack-allocated variable
// !begin
// ! Doc.InitArray(['one',2,3.0]);
// ! assert(Doc.Count=3);
// !end;
// which is the same as:
// ! var Doc: TDocVariantData;
// ! i: integer;
// !begin
// ! Doc.Init;
// ! Doc.AddItem('one');
// ! Doc.AddItem(2);
// ! Doc.AddItem(3.0);
// ! assert(Doc.Count=3);
// ! for i := 0 to Doc.Count-1 do
// ! writeln(Doc.Value[i]);
// !end;
// - this method is called e.g. by _Arr() and _ArrFast() global functions
// - if you call Init*() methods in a row, ensure you call Clear in-between
procedure InitArray(const Items: array of const;
aOptions: TDocVariantOptions=[]);
/// initialize a variant instance to store some document-based array content
// - array will be initialized with data supplied as variant dynamic array
// - if Items is [], the variant will be set as null
// - will be almost immediate, since TVariantDynArray is reference-counted,
// unless ItemsCopiedByReference is set to FALSE
// - if you call Init*() methods in a row, ensure you call Clear in-between
procedure InitArrayFromVariants(const Items: TVariantDynArray;
aOptions: TDocVariantOptions=[]; ItemsCopiedByReference: boolean=true);
/// initialize a variant instance to store some RawUTF8 array content
procedure InitArrayFrom(const Items: TRawUTF8DynArray; aOptions: TDocVariantOptions); overload;
/// initialize a variant instance to store some 32-bit integer array content
procedure InitArrayFrom(const Items: TIntegerDynArray; aOptions: TDocVariantOptions); overload;
/// initialize a variant instance to store some 64-bit integer array content
procedure InitArrayFrom(const Items: TInt64DynArray; aOptions: TDocVariantOptions); overload;
/// initialize a variant instance to store a T*ObjArray content
// - will call internally ObjectToVariant() to make the conversion
procedure InitArrayFromObjArray(const ObjArray; aOptions: TDocVariantOptions;
aWriterOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]);
/// initialize a variant instance to store document-based array content
// - array will be initialized from the supplied variable (which would be
// e.g. a T*ObjArray or a dynamic array), using RTTI
// - will use a temporary JSON serialization via SaveJSON()
procedure InitFromTypeInfo(const aValue; aTypeInfo: pointer;
aEnumSetsAsText: boolean; aOptions: TDocVariantOptions);
/// initialize a variant instance to store some document-based object content
// - object will be initialized with names and values supplied as dynamic arrays
// - if aNames and aValues are [] or do have matching sizes, the variant
// will be set as null
// - will be almost immediate, since Names and Values are reference-counted
// - if you call Init*() methods in a row, ensure you call Clear in-between
procedure InitObjectFromVariants(const aNames: TRawUTF8DynArray;
const aValues: TVariantDynArray; aOptions: TDocVariantOptions=[]);
/// initialize a variant instance to store a document-based object with a
// single property
// - the supplied path could be 'Main.Second.Third', to create nested
// objects, e.g. {"Main":{"Second":{"Third":value}}}
// - if you call Init*() methods in a row, ensure you call Clear in-between
procedure InitObjectFromPath(const aPath: RawUTF8; const aValue: variant;
aOptions: TDocVariantOptions=[]);
/// initialize a variant instance to store some document-based object content
// from a supplied JSON array or JSON object content
// - warning: the incoming JSON buffer will be modified in-place: so you should
// make a private copy before running this method, e.g. using TSynTempBuffer
// - this method is called e.g. by _JsonFmt() _JsonFastFmt() global functions
// with a temporary JSON buffer content created from a set of parameters
// - if you call Init*() methods in a row, ensure you call Clear in-between
function InitJSONInPlace(JSON: PUTF8Char;
aOptions: TDocVariantOptions=[]; aEndOfObject: PUTF8Char=nil): PUTF8Char;
/// initialize a variant instance to store some document-based object content
// from a supplied JSON array of JSON object content
// - a private copy of the incoming JSON buffer will be used, then
// it will call the other overloaded InitJSONInPlace() method
// - this method is called e.g. by _Json() and _JsonFast() global functions
// - if you call Init*() methods in a row, ensure you call Clear in-between
function InitJSON(const JSON: RawUTF8; aOptions: TDocVariantOptions=[]): boolean;
/// initialize a variant instance to store some document-based object content
// from a JSON array of JSON object content, stored in a file
// - any kind of file encoding will be handled, via AnyTextFileToRawUTF8()
// - you can optionally remove any comment from the file content
// - if you call Init*() methods in a row, ensure you call Clear in-between
function InitJSONFromFile(const JsonFile: TFileName; aOptions: TDocVariantOptions=[];
RemoveComments: boolean=false): boolean;
/// ensure a document-based variant instance will have one unique options set
// - this will create a copy of the supplied TDocVariant instance, forcing
// all nested events to have the same set of Options
// - you can use this function to ensure that all internal properties of this
// variant will be copied e.g. per-reference (if you set JSON_OPTIONS[false])
// or per-value (if you set JSON_OPTIONS[false]) whatever options the nested
// objects or arrays were created with
// - will raise an EDocVariant if the supplied variant is not a TDocVariant
// - you may rather use _Unique() or _UniqueFast() wrappers if you want to
// ensure that a TDocVariant instance is unique
// - if you call Init*() methods in a row, ensure you call Clear in-between
procedure InitCopy(const SourceDocVariant: variant; aOptions: TDocVariantOptions);
/// initialize a variant instance to store some document-based object content
// from a supplied CSV UTF-8 encoded text
// - the supplied content may have been generated by ToTextPairs() method
// - if ItemSep=#10, then any kind of line feed (CRLF or LF) will be handled
// - if you call Init*() methods in a row, ensure you call Clear in-between
procedure InitCSV(CSV: PUTF8Char; aOptions: TDocVariantOptions;
NameValueSep: AnsiChar='='; ItemSep: AnsiChar=#10; DoTrim: boolean=true); overload;
/// initialize a variant instance to store some document-based object content
// from a supplied CSV UTF-8 encoded text
// - the supplied content may have been generated by ToTextPairs() method
// - if ItemSep=#10, then any kind of line feed (CRLF or LF) will be handled
// - if you call Init*() methods in a row, ensure you call Clear in-between
procedure InitCSV(const CSV: RawUTF8; aOptions: TDocVariantOptions;
NameValueSep: AnsiChar='='; ItemSep: AnsiChar=#10; DoTrim: boolean=true); overload;
{$ifdef HASINLINE}inline;{$endif}
/// to be called before any Init*() method call, when a previous Init*()
// has already be performed on the same instance, to avoid memory leaks
// - for instance:
// !var Doc: TDocVariantData; // stack-allocated variable
// !begin
// ! Doc.InitArray(['one',2,3.0]); // no need of any Doc.Clear here
// ! assert(Doc.Count=3);
// ! Doc.Clear; // to release memory before following InitObject()
// ! Doc.InitObject(['name','John','year',1972]);
// !end;
// - implemented as just a wrapper around DocVariantType.Clear()
procedure Clear;
/// delete all internal stored values
// - like Clear + Init() with the same options
// - will reset Kind to dvUndefined
procedure Reset;
/// fill all Values[] with #0, then delete all values
// - could be used to specifically remove sensitive information from memory
procedure FillZero;
/// low-level method to force a number of items
// - could be used to fast add items to the internal Values[]/Names[] arrays
// - just set protected VCount field, do not resize the arrays: caller
// should ensure that Capacity is big enough
procedure SetCount(aCount: integer); {$ifdef HASINLINE}inline;{$endif}
/// low-level method called internally to reserve place for new values
// - returns the index of the newly created item in Values[]/Names[] arrays
// - you should not have to use it, unless you want to add some items
// directly within the Values[]/Names[] arrays, using e.g.
// InitFast(InitialCapacity) to initialize the document
// - if aName='', append a dvArray item, otherwise append a dvObject field
// - warning: FPC optimizer is confused by Values[InternalAdd(name)] so
// you should call InternalAdd() in an explicit previous step
function InternalAdd(const aName: RawUTF8): integer;
/// save a document as UTF-8 encoded JSON
// - will write either a JSON object or array, depending of the internal
// layout of this instance (i.e. Kind property value)
// - will write 'null' if Kind is dvUndefined
// - implemented as just a wrapper around VariantSaveJSON()
function ToJSON(const Prefix: RawUTF8=''; const Suffix: RawUTF8='';
Format: TTextWriterJSONFormat=jsonCompact): RawUTF8;
/// save an array of objects as UTF-8 encoded non expanded layout JSON
// - returned content would be a JSON object in mORMot's TSQLTable non
// expanded format, with reduced JSON size, i.e.
// $ {"fieldCount":3,"values":["ID","FirstName","LastName",...']}
// - will write '' if Kind is dvUndefined or dvObject
// - will raise an exception if the array document is not an array of
// objects with identical field names
function ToNonExpandedJSON: RawUTF8;
/// save a document as an array of UTF-8 encoded JSON
// - will expect the document to be a dvArray - otherwise, will raise a
// EDocVariant exception
// - will use VariantToUTF8() to populate the result array: as a consequence,
// any nested custom variant types (e.g. TDocVariant) will be stored as JSON
procedure ToRawUTF8DynArray(out Result: TRawUTF8DynArray); overload;
/// save a document as an array of UTF-8 encoded JSON
// - will expect the document to be a dvArray - otherwise, will raise a
// EDocVariant exception
// - will use VariantToUTF8() to populate the result array: as a consequence,
// any nested custom variant types (e.g. TDocVariant) will be stored as JSON
function ToRawUTF8DynArray: TRawUTF8DynArray; overload;
{$ifdef HASINLINE}inline;{$endif}
/// save a document as an CSV of UTF-8 encoded JSON
// - will expect the document to be a dvArray - otherwise, will raise a
// EDocVariant exception
// - will use VariantToUTF8() to populate the result array: as a consequence,
// any nested custom variant types (e.g. TDocVariant) will be stored as JSON
function ToCSV(const Separator: RawUTF8=','): RawUTF8;
/// save a document as UTF-8 encoded Name=Value pairs
// - will follow by default the .INI format, but you can specify your
// own expected layout
procedure ToTextPairsVar(out result: RawUTF8; const NameValueSep: RawUTF8='=';
const ItemSep: RawUTF8=#13#10; Escape: TTextWriterKind=twJSONEscape);
/// save a document as UTF-8 encoded Name=Value pairs
// - will follow by default the .INI format, but you can specify your
// own expected layout
function ToTextPairs(const NameValueSep: RawUTF8='=';
const ItemSep: RawUTF8=#13#10; Escape: TTextWriterKind=twJSONEscape): RawUTF8;
{$ifdef HASINLINE}inline;{$endif}
/// save an array document as an array of TVarRec, i.e. an array of const
// - will expect the document to be a dvArray - otherwise, will raise a
// EDocVariant exception
// - would allow to write code as such:
// ! Doc.InitArray(['one',2,3]);
// ! Doc.ToArrayOfConst(vr);
// ! s := FormatUTF8('[%,%,%]',vr,[],true);
// ! // here s='[one,2,3]') since % would be replaced by Args[] parameters
// ! s := FormatUTF8('[?,?,?]',[],vr,true);
// ! // here s='["one",2,3]') since ? would be escaped by Params[] parameters
procedure ToArrayOfConst(out Result: TTVarRecDynArray); overload;
/// save an array document as an array of TVarRec, i.e. an array of const
// - will expect the document to be a dvArray - otherwise, will raise a
// EDocVariant exception
// - would allow to write code as such:
// ! Doc.InitArray(['one',2,3]);
// ! s := FormatUTF8('[%,%,%]',Doc.ToArrayOfConst,[],true);
// ! // here s='[one,2,3]') since % would be replaced by Args[] parameters
// ! s := FormatUTF8('[?,?,?]',[],Doc.ToArrayOfConst,true);
// ! // here s='["one",2,3]') since ? would be escaped by Params[] parameters
function ToArrayOfConst: TTVarRecDynArray; overload;
{$ifdef HASINLINE}inline;{$endif}
/// save an object document as an URI-encoded list of parameters
// - object field names should be plain ASCII-7 RFC compatible identifiers
// (0..9a..zA..Z_.~), otherwise their values are skipped
function ToUrlEncode(const UriRoot: RawUTF8): RawUTF8;
/// find an item index in this document from its name
// - search will follow dvoNameCaseSensitive option of this document
// - lookup the value by name for an object document, or accept an integer
// text as index for an array document
// - returns -1 if not found
function GetValueIndex(const aName: RawUTF8): integer; overload;
{$ifdef HASINLINE}inline;{$endif}
/// find an item index in this document from its name
// - lookup the value by name for an object document, or accept an integer
// text as index for an array document
// - returns -1 if not found
function GetValueIndex(aName: PUTF8Char; aNameLen: PtrInt; aCaseSensitive: boolean): integer; overload;
/// find an item in this document, and returns its value
// - raise an EDocVariant if not found and dvoReturnNullForUnknownProperty
// is not set in Options (in this case, it will return Null)
function GetValueOrRaiseException(const aName: RawUTF8): variant;
/// find an item in this document, and returns its value
// - return the supplied default if aName is not found, or if the instance
// is not a TDocVariant
function GetValueOrDefault(const aName: RawUTF8; const aDefault: variant): variant;
/// find an item in this document, and returns its value
// - return null if aName is not found, or if the instance is not a TDocVariant
function GetValueOrNull(const aName: RawUTF8): variant;
/// find an item in this document, and returns its value
// - return a cleared variant if aName is not found, or if the instance is
// not a TDocVariant
function GetValueOrEmpty(const aName: RawUTF8): variant;
/// find an item in this document, and returns its value as enumerate
// - return false if aName is not found, if the instance is not a TDocVariant,
// or if the value is not a string corresponding to the supplied enumerate
// - return true if the name has been found, and aValue stores the value
// - will call Delete() on the found entry, if aDeleteFoundEntry is true
function GetValueEnumerate(const aName: RawUTF8; aTypeInfo: pointer;
out aValue; aDeleteFoundEntry: boolean=false): Boolean;
/// returns a TDocVariant object containing all properties matching the
// first characters of the supplied property name
// - returns null if the document is not a dvObject
// - will use IdemPChar(), so search would be case-insensitive
function GetValuesByStartName(const aStartName: RawUTF8;
TrimLeftStartName: boolean=false): variant;
/// returns a JSON object containing all properties matching the
// first characters of the supplied property name
// - returns null if the document is not a dvObject
// - will use IdemPChar(), so search would be case-insensitive
function GetJsonByStartName(const aStartName: RawUTF8): RawUTF8;
/// find an item in this document, and returns its value as TVarData
// - return false if aName is not found, or if the instance is not a TDocVariant
// - return true and set aValue if the name has been found
// - will use simple loop lookup to identify the name, unless aSortedCompare is
// set, and would let use a faster O(log(n)) binary search after a SortByName()
function GetVarData(const aName: RawUTF8; var aValue: TVarData;
aSortedCompare: TUTF8Compare=nil): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// find an item in this document, and returns its value as TVarData pointer
// - return nil if aName is not found, or if the instance is not a TDocVariant
// - return a pointer to the value if the name has been found
// - after a SortByName(aSortedCompare), could use faster binary search
function GetVarData(const aName: RawUTF8;
aSortedCompare: TUTF8Compare=nil): PVarData; overload;
/// find an item in this document, and returns its value as boolean
// - return false if aName is not found, or if the instance is not a TDocVariant
// - return true if the name has been found, and aValue stores the value
// - after a SortByName(aSortedCompare), could use faster binary search
// - consider using B[] property if you want simple read/write typed access
function GetAsBoolean(const aName: RawUTF8; out aValue: boolean;
aSortedCompare: TUTF8Compare=nil): Boolean;
/// find an item in this document, and returns its value as integer
// - return false if aName is not found, or if the instance is not a TDocVariant
// - return true if the name has been found, and aValue stores the value
// - after a SortByName(aSortedCompare), could use faster binary search
// - consider using I[] property if you want simple read/write typed access
function GetAsInteger(const aName: RawUTF8; out aValue: integer;
aSortedCompare: TUTF8Compare=nil): Boolean;
/// find an item in this document, and returns its value as integer
// - return false if aName is not found, or if the instance is not a TDocVariant
// - return true if the name has been found, and aValue stores the value
// - after a SortByName(aSortedCompare), could use faster binary search
// - consider using I[] property if you want simple read/write typed access
function GetAsInt64(const aName: RawUTF8; out aValue: Int64;
aSortedCompare: TUTF8Compare=nil): Boolean;
/// find an item in this document, and returns its value as floating point
// - return false if aName is not found, or if the instance is not a TDocVariant
// - return true if the name has been found, and aValue stores the value
// - after a SortByName(aSortedCompare), could use faster binary search
// - consider using D[] property if you want simple read/write typed access
function GetAsDouble(const aName: RawUTF8; out aValue: double;
aSortedCompare: TUTF8Compare=nil): Boolean;
/// find an item in this document, and returns its value as RawUTF8
// - return false if aName is not found, or if the instance is not a TDocVariant
// - return true if the name has been found, and aValue stores the value
// - after a SortByName(aSortedCompare), could use faster binary search
// - consider using U[] property if you want simple read/write typed access
function GetAsRawUTF8(const aName: RawUTF8; out aValue: RawUTF8;
aSortedCompare: TUTF8Compare=nil): Boolean;
/// find an item in this document, and returns its value as a TDocVariantData
// - return false if aName is not found, or if the instance is not a TDocVariant
// - return true if the name has been found and points to a TDocVariant:
// then aValue stores a pointer to the value
// - after a SortByName(aSortedCompare), could use faster binary search
function GetAsDocVariant(const aName: RawUTF8; out aValue: PDocVariantData;
aSortedCompare: TUTF8Compare=nil): boolean; overload;
/// find an item in this document, and returns its value as a TDocVariantData
// - returns a void TDocVariant if aName is not a document
// - after a SortByName(aSortedCompare), could use faster binary search
// - consider using O[] or A[] properties if you want simple read-only
// access, or O_[] or A_[] properties if you want the ability to add
// a missing object or array in the document
function GetAsDocVariantSafe(const aName: RawUTF8;
aSortedCompare: TUTF8Compare=nil): PDocVariantData;
/// find an item in this document, and returns pointer to its value
// - return false if aName is not found
// - return true if the name has been found: then aValue stores a pointer
// to the value
// - after a SortByName(aSortedCompare), could use faster binary search
function GetAsPVariant(const aName: RawUTF8; out aValue: PVariant;
aSortedCompare: TUTF8Compare=nil): boolean; overload; {$ifdef HASINLINE}inline;{$endif}
/// find an item in this document, and returns pointer to its value
// - lookup the value by aName/aNameLen for an object document, or accept
// an integer text as index for an array document
// - return nil if aName is not found, or if the instance is not a TDocVariant
// - return a pointer to the stored variant, if the name has been found
function GetAsPVariant(aName: PUTF8Char; aNameLen: PtrInt): PVariant; overload;
{$ifdef HASINLINE}inline;{$endif}
/// retrieve a value, given its path
// - path is defined as a dotted name-space, e.g. 'doc.glossary.title'
// - it will return Unassigned if the path does match the supplied aPath
function GetValueByPath(const aPath: RawUTF8): variant; overload;
/// retrieve a value, given its path
// - path is defined as a dotted name-space, e.g. 'doc.glossary.title'
// - it will return FALSE if the path does not match the supplied aPath
// - returns TRUE and set the found value in aValue
function GetValueByPath(const aPath: RawUTF8; out aValue: variant): boolean; overload;
/// retrieve a value, given its path
// - path is defined as a list of names, e.g. ['doc','glossary','title']
// - it will return Unassigned if the path does not match the data
// - this method will only handle nested TDocVariant values: use the
// slightly slower GetValueByPath() overloaded method, if any nested object
// may be of another type (e.g. a TBSONVariant)
function GetValueByPath(const aDocVariantPath: array of RawUTF8): variant; overload;
/// retrieve a reference to a value, given its path
// - path is defined as a dotted name-space, e.g. 'doc.glossary.title'
// - if the supplied aPath does not match any object, it will return nil
// - if aPath is found, returns a pointer to the corresponding value
function GetPVariantByPath(const aPath: RawUTF8): PVariant;
/// retrieve a reference to a TDocVariant, given its path
// - path is defined as a dotted name-space, e.g. 'doc.glossary.title'
// - if the supplied aPath does not match any object, it will return false
// - if aPath stores a valid TDocVariant, returns true and a pointer to it
function GetDocVariantByPath(const aPath: RawUTF8; out aValue: PDocVariantData): boolean;
/// retrieve a dvObject in the dvArray, from a property value
// - {aPropName:aPropValue} will be searched within the stored array,
// and the corresponding item will be copied into Dest, on match
// - returns FALSE if no match is found, TRUE if found and copied
// - create a copy of the variant by default, unless DestByRef is TRUE
// - will call VariantEquals() for value comparison
function GetItemByProp(const aPropName,aPropValue: RawUTF8;
aPropValueCaseSensitive: boolean; var Dest: variant; DestByRef: boolean=false): boolean;
/// retrieve a reference to a dvObject in the dvArray, from a property value
// - {aPropName:aPropValue} will be searched within the stored array,
// and the corresponding item will be copied into Dest, on match
// - returns FALSE if no match is found, TRUE if found and copied by reference
function GetDocVariantByProp(const aPropName,aPropValue: RawUTF8;
aPropValueCaseSensitive: boolean; out Dest: PDocVariantData): boolean;
/// find an item in this document, and returns its value
// - raise an EDocVariant if not found and dvoReturnNullForUnknownProperty
// is not set in Options (in this case, it will return Null)
// - create a copy of the variant by default, unless DestByRef is TRUE
function RetrieveValueOrRaiseException(aName: PUTF8Char; aNameLen: integer;
aCaseSensitive: boolean; var Dest: variant; DestByRef: boolean): boolean; overload;
/// retrieve an item in this document from its index, and returns its value
// - raise an EDocVariant if the supplied Index is not in the 0..Count-1
// range and dvoReturnNullForUnknownProperty is set in Options
// - create a copy of the variant by default, unless DestByRef is TRUE
procedure RetrieveValueOrRaiseException(Index: integer;
var Dest: variant; DestByRef: boolean); overload;
/// retrieve an item in this document from its index, and returns its Name
// - raise an EDocVariant if the supplied Index is not in the 0..Count-1
// range and dvoReturnNullForUnknownProperty is set in Options
procedure RetrieveNameOrRaiseException(Index: integer; var Dest: RawUTF8);
/// set an item in this document from its index
// - raise an EDocVariant if the supplied Index is not in 0..Count-1 range
procedure SetValueOrRaiseException(Index: integer; const NewValue: variant);
/// add a value in this document
// - if aName is set, if dvoCheckForDuplicatedNames option is set, any
// existing duplicated aName will raise an EDocVariant; if instance's
// kind is dvArray and aName is defined, it will raise an EDocVariant
// - aName may be '' e.g. if you want to store an array: in this case,
// dvoCheckForDuplicatedNames option should not be set; if instance's Kind
// is dvObject, it will raise an EDocVariant exception
// - if aValueOwned is true, then the supplied aValue will be assigned to
// the internal values - by default, it will use SetVariantByValue()
// - you can therefore write e.g.:
// ! TDocVariant.New(aVariant);
// ! Assert(TDocVariantData(aVariant).Kind=dvUndefined);
// ! TDocVariantData(aVariant).AddValue('name','John');
// ! Assert(TDocVariantData(aVariant).Kind=dvObject);
// - returns the index of the corresponding newly added value
function AddValue(const aName: RawUTF8; const aValue: variant;
aValueOwned: boolean=false): integer; overload;
/// add a value in this document
// - overloaded function accepting a UTF-8 encoded buffer for the name
function AddValue(aName: PUTF8Char; aNameLen: integer; const aValue: variant;
aValueOwned: boolean=false): integer; overload;
/// add a value in this document, or update an existing entry
// - if instance's Kind is dvArray, it will raise an EDocVariant exception
// - any existing Name would be updated with the new Value, unless
// OnlyAddMissing is set to TRUE, in which case existing values would remain
// - returns the index of the corresponding value, which may be just added
function AddOrUpdateValue(const aName: RawUTF8; const aValue: variant;
wasAdded: PBoolean=nil; OnlyAddMissing: boolean=false): integer;
/// add a value in this document, from its text representation
// - this function expects a UTF-8 text for the value, which would be
// converted to a variant number, if possible (as varInt/varInt64/varCurrency
// and/or as varDouble is AllowVarDouble is set)
// - if Update=TRUE, will set the property, even if it is existing
function AddValueFromText(const aName,aValue: RawUTF8; Update: boolean=false;
AllowVarDouble: boolean=false): integer;
/// add some properties to a TDocVariantData dvObject
// - data is supplied two by two, as Name,Value pairs
// - caller should ensure that Kind=dvObject, otherwise it won't do anything
// - any existing Name would be duplicated
procedure AddNameValuesToObject(const NameValuePairs: array of const);
/// merge some properties to a TDocVariantData dvObject
// - data is supplied two by two, as Name,Value pairs
// - caller should ensure that Kind=dvObject, otherwise it won't do anything
// - any existing Name would be updated with the new Value
procedure AddOrUpdateNameValuesToObject(const NameValuePairs: array of const);
/// merge some TDocVariantData dvObject properties to a TDocVariantData dvObject
// - data is supplied two by two, as Name,Value pairs
// - caller should ensure that both variants have Kind=dvObject, otherwise
// it won't do anything
// - any existing Name would be updated with the new Value, unless
// OnlyAddMissing is set to TRUE, in which case existing values would remain
procedure AddOrUpdateObject(const NewValues: variant; OnlyAddMissing: boolean=false;
RecursiveUpdate: boolean=false);
/// add a value to this document, handled as array
// - if instance's Kind is dvObject, it will raise an EDocVariant exception
// - you can therefore write e.g.:
// ! TDocVariant.New(aVariant);
// ! Assert(TDocVariantData(aVariant).Kind=dvUndefined);
// ! TDocVariantData(aVariant).AddItem('one');
// ! Assert(TDocVariantData(aVariant).Kind=dvArray);
// - returns the index of the corresponding newly added item
function AddItem(const aValue: variant): integer;
/// add a value to this document, handled as array, from its text representation
// - this function expects a UTF-8 text for the value, which would be
// converted to a variant number, if possible (as varInt/varInt64/varCurrency
// unless AllowVarDouble is set)
// - if instance's Kind is dvObject, it will raise an EDocVariant exception
// - returns the index of the corresponding newly added item
function AddItemFromText(const aValue: RawUTF8;
AllowVarDouble: boolean=false): integer;
/// add a RawUTF8 value to this document, handled as array
// - if instance's Kind is dvObject, it will raise an EDocVariant exception
// - returns the index of the corresponding newly added item
function AddItemText(const aValue: RawUTF8): integer;
/// add one or several values to this document, handled as array
// - if instance's Kind is dvObject, it will raise an EDocVariant exception
procedure AddItems(const aValue: array of const);
/// add one or several values from another document
// - supplied document should be of the same kind than the current one,
// otherwise nothing is added
procedure AddFrom(const aDocVariant: Variant);
/// add or update or on several valeus from another object
// - current document should be an object
procedure AddOrUpdateFrom(const aDocVariant: Variant; aOnlyAddMissing: boolean=false);
/// add one or several properties, specified by path, from another object
// - path are defined as a dotted name-space, e.g. 'doc.glossary.title'
// - matching values would be added as root values, with the path as name
// - instance and supplied aSource should be a dvObject
procedure AddByPath(const aSource: TDocVariantData; const aPaths: array of RawUTF8);
/// delete a value/item in this document, from its index
// - return TRUE on success, FALSE if the supplied index is not correct
function Delete(Index: integer): boolean; overload;
/// delete a value/item in this document, from its name
// - return TRUE on success, FALSE if the supplied name does not exist
function Delete(const aName: RawUTF8): boolean; overload;
/// delete a value in this document, by property name match
// - {aPropName:aPropValue} will be searched within the stored array or
// object, and the corresponding item will be deleted, on match
// - returns FALSE if no match is found, TRUE if found and deleted
// - will call VariantEquals() for value comparison
function DeleteByProp(const aPropName,aPropValue: RawUTF8;
aPropValueCaseSensitive: boolean): boolean;
/// delete one or several value/item in this document, from its value
// - returns the number of deleted items
// - returns 0 if the document is not a dvObject, or if no match was found
// - if the value exists several times, all occurences would be removed
// - is optimized for DeleteByValue(null) call
function DeleteByValue(const aValue: Variant; CaseInsensitive: boolean=false): integer;
/// delete all values matching the first characters of a property name
// - returns the number of deleted items
// - returns 0 if the document is not a dvObject, or if no match was found
// - will use IdemPChar(), so search would be case-insensitive
function DeleteByStartName(aStartName: PUTF8Char; aStartNameLen: integer): integer;
/// search a property match in this document, handled as array or object
// - {aPropName:aPropValue} will be searched within the stored array or
// object, and the corresponding item index will be returned, on match
// - returns -1 if no match is found
// - will call VariantEquals() for value comparison
function SearchItemByProp(const aPropName,aPropValue: RawUTF8;
aPropValueCaseSensitive: boolean): integer; overload;
/// search a property match in this document, handled as array or object
// - {aPropName:aPropValue} will be searched within the stored array or
// object, and the corresponding item index will be returned, on match
// - returns -1 if no match is found
// - will call VariantEquals() for value comparison
function SearchItemByProp(const aPropNameFmt: RawUTF8; const aPropNameArgs: array of const;
const aPropValue: RawUTF8; aPropValueCaseSensitive: boolean): integer; overload;
/// search a value in this document, handled as array
// - aValue will be searched within the stored array
// and the corresponding item index will be returned, on match
// - returns -1 if no match is found
// - you could make several searches, using the StartIndex optional parameter
function SearchItemByValue(const aValue: Variant;
CaseInsensitive: boolean=false; StartIndex: integer=0): integer;
/// sort the document object values by name
// - do nothing if the document is not a dvObject
// - will follow case-insensitive order (@StrIComp) by default, but you
// can specify @StrComp as comparer function for case-sensitive ordering
// - once sorted, you can use GetVarData(..,Compare) or GetAs*(..,Compare)
// methods for much faster O(log(n)) binary search
procedure SortByName(Compare: TUTF8Compare=nil);
/// sort the document object values by value
// - work for both dvObject and dvArray documents
// - will sort by UTF-8 text (VariantCompare) if no custom aCompare is supplied
procedure SortByValue(Compare: TVariantCompare = nil);
/// sort the document array values by a field of some stored objet values
// - do nothing if the document is not a dvArray, or if the items are no dvObject
// - will sort by UTF-8 text (VariantCompare) if no custom aValueCompare is supplied
procedure SortArrayByField(const aItemPropName: RawUTF8;
aValueCompare: TVariantCompare=nil; aValueCompareReverse: boolean=false;
aNameSortedCompare: TUTF8Compare=nil);
/// reverse the order of the document object or array items
procedure Reverse;
/// create a TDocVariant object, from a selection of properties of this
// document, by property name
// - if the document is a dvObject, to reduction will be applied to all
// its properties
// - if the document is a dvArray, the reduction will be applied to each
// stored item, if it is a document
procedure Reduce(const aPropNames: array of RawUTF8; aCaseSensitive: boolean;
out result: TDocVariantData; aDoNotAddVoidProp: boolean=false); overload;
/// create a TDocVariant object, from a selection of properties of this
// document, by property name
// - always returns a TDocVariantData, even if no property name did match
// (in this case, it is dvUndefined)
function Reduce(const aPropNames: array of RawUTF8; aCaseSensitive: boolean;
aDoNotAddVoidProp: boolean=false): variant; overload;
/// create a TDocVariant array, from the values of a single properties of
// this document, specified by name
// - you can optionally apply an additional filter to each reduced item
procedure ReduceAsArray(const aPropName: RawUTF8; out result: TDocVariantData;
OnReduce: TOnReducePerItem=nil); overload;
/// create a TDocVariant array, from the values of a single properties of
// this document, specified by name
// - always returns a TDocVariantData, even if no property name did match
// (in this case, it is dvUndefined)
// - you can optionally apply an additional filter to each reduced item
function ReduceAsArray(const aPropName: RawUTF8; OnReduce: TOnReducePerItem=nil): variant; overload;
/// create a TDocVariant array, from the values of a single properties of
// this document, specified by name
// - this overloaded method accepts an additional filter to each reduced item
procedure ReduceAsArray(const aPropName: RawUTF8; out result: TDocVariantData;
OnReduce: TOnReducePerValue); overload;
/// create a TDocVariant array, from the values of a single properties of
// this document, specified by name
// - always returns a TDocVariantData, even if no property name did match
// (in this case, it is dvUndefined)
// - this overloaded method accepts an additional filter to each reduced item
function ReduceAsArray(const aPropName: RawUTF8; OnReduce: TOnReducePerValue): variant; overload;
/// rename some properties of a TDocVariant object
// - returns the number of property names modified
function Rename(const aFromPropName, aToPropName: TRawUTF8DynArray): integer;
/// map {"obj.prop1"..,"obj.prop2":..} into {"obj":{"prop1":..,"prop2":...}}
// - the supplied aObjectPropName should match the incoming dotted value
// of all properties (e.g. 'obj' for "obj.prop1")
// - if any of the incoming property is not of "obj.prop#" form, the
// whole process would be ignored
// - return FALSE if the TDocVariant did not change
// - return TRUE if the TDocVariant has been flattened
function FlattenAsNestedObject(const aObjectPropName: RawUTF8): boolean;
/// how this document will behave
// - those options are set when creating the instance
// - dvoArray and dvoObject are not options, but define the document Kind,
// so those items are ignored when assigned to this property
property Options: TDocVariantOptions read VOptions write SetOptions;
/// returns the document internal layout
// - just after initialization, it will return dvUndefined
// - most of the time, you will add named values with AddValue() or by
// setting the variant properties: it will return dvObject
// - but is you use AddItem(), values will have no associated names: the
// document will be a dvArray
// - value computed from the dvoArray and dvoObject presence in Options
property Kind: TDocVariantKind read GetKind;
/// return the custom variant type identifier, i.e. DocVariantType.VarType
property VarType: word read VType;
/// number of items stored in this document
// - is 0 if Kind=dvUndefined
// - is the number of name/value pairs for Kind=dvObject
// - is the number of items for Kind=dvArray
property Count: integer read VCount;
/// the current capacity of this document
// - allow direct access to VValue[] length
property Capacity: integer read GetCapacity write SetCapacity;
/// direct acces to the low-level internal array of values
// - transtyping a variant and direct access to TDocVariantData is the
// fastest way of accessing all properties of a given dvObject:
// ! with TDocVariantData(aVariantObject) do
// ! for i := 0 to Count-1 do
// ! writeln(Names[i],'=',Values[i]);
// - or to access a dvArray items (e.g. a MongoDB collection):
// ! with TDocVariantData(aVariantArray) do
// ! for i := 0 to Count-1 do
// ! writeln(Values[i]);
property Values: TVariantDynArray read VValue;
/// direct acces to the low-level internal array of names
// - is void (nil) if Kind is not dvObject
// - transtyping a variant and direct access to TDocVariantData is the
// fastest way of accessing all properties of a given dvObject:
// ! with TDocVariantData(aVariantObject) do
// ! for i := 0 to Count-1 do
// ! writeln(Names[i],'=',Values[i]);
property Names: TRawUTF8DynArray read VName;
/// find an item in this document, and returns its value
// - raise an EDocVariant if aNameOrIndex is neither an integer nor a string
// - raise an EDocVariant if Kind is dvArray and aNameOrIndex is a string
// or if Kind is dvObject and aNameOrIndex is an integer
// - raise an EDocVariant if Kind is dvObject and if aNameOrIndex is a
// string, which is not found within the object property names and
// dvoReturnNullForUnknownProperty is set in Options
// - raise an EDocVariant if Kind is dvArray and if aNameOrIndex is a
// integer, which is not within 0..Count-1 and dvoReturnNullForUnknownProperty
// is set in Options
// - so you can use directly:
// ! // for an array document:
// ! aVariant := TDocVariant.NewArray(['one',2,3.0]);
// ! for i := 0 to TDocVariantData(aVariant).Count-1 do
// ! aValue := TDocVariantData(aVariant).Value[i];
// ! // for an object document:
// ! aVariant := TDocVariant.NewObject(['name','John','year',1972]);
// ! assert(aVariant.Name=TDocVariantData(aVariant)['name']);
// ! assert(aVariant.year=TDocVariantData(aVariant)['year']);
// - due to the internal implementation of variant execution (somewhat
// slow _DispInvoke() function), it is a bit faster to execute:
// ! aValue := TDocVariantData(aVariant).Value['name'];
// instead of
// ! aValue := aVariant.name;
// but of course, if want to want to access the content by index (typically
// for a dvArray), using Values[] - and Names[] - properties is much faster
// than this variant-indexed pseudo-property:
// ! with TDocVariantData(aVariant) do
// ! for i := 0 to Count-1 do
// ! Writeln(Values[i]);
// is faster than:
// ! with TDocVariantData(aVariant) do
// ! for i := 0 to Count-1 do
// ! Writeln(Value[i]);
// which is faster than:
// ! for i := 0 to aVariant.Count-1 do
// ! Writeln(aVariant._(i));
// - this property will return the value as varByRef (just like with
// variant late binding of any TDocVariant instance), so you can write:
// !var Doc: TDocVariantData; // stack-allocated variable
// !begin
// ! Doc.InitJSON('{arr:[1,2]}');
// ! assert(Doc.Count=2);
// ! Doc.Value['arr'].Add(3); // works since Doc.Value['arr'] is varByRef
// ! writeln(Doc.ToJSON); // will write '{"arr":[1,2,3]}'
// !end;
// - if you want to access a property as a copy, i.e. to assign it to a
// variant variable which will stay alive after this TDocVariant instance
// is release, you should not use Value[] but rather
// GetValueOrRaiseException or GetValueOrNull/GetValueOrEmpty
// - see U[] I[] B[] D[] O[] O_[] A[] A_[] _[] properties for direct access
// of strong typed values
property Value[const aNameOrIndex: Variant]: Variant read GetValueOrItem
write SetValueOrItem; default;
/// direct access to a dvObject UTF-8 stored property value from its name
// - slightly faster than the variant-based Value[] default property
// - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options
// - use GetAsRawUTF8() if you want to check the availability of the field
// - U['prop'] := 'value' would add a new property, or overwrite an existing
property U[const aName: RawUTF8]: RawUTF8 read GetRawUTF8ByName write SetRawUTF8ByName;
/// direct string access to a dvObject UTF-8 stored property value from its name
// - just a wrapper around U[] property, to avoid a compilation warning when
// using plain string variables (internaly, RawUTF8 will be used for storage)
// - slightly faster than the variant-based Value[] default property
// - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options
// - use GetAsRawUTF8() if you want to check the availability of the field
// - S['prop'] := 'value' would add a new property, or overwrite an existing
property S[const aName: RawUTF8]: string read GetStringByName write SetStringByName;
/// direct access to a dvObject Integer stored property value from its name
// - slightly faster than the variant-based Value[] default property
// - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options
// - use GetAsInt/GetAsInt64 if you want to check the availability of the field
// - I['prop'] := 123 would add a new property, or overwrite an existing
property I[const aName: RawUTF8]: Int64 read GetInt64ByName write SetInt64ByName;
/// direct access to a dvObject Boolean stored property value from its name
// - slightly faster than the variant-based Value[] default property
// - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options
// - use GetAsBoolean if you want to check the availability of the field
// - B['prop'] := true would add a new property, or overwrite an existing
property B[const aName: RawUTF8]: Boolean read GetBooleanByName write SetBooleanByName;
/// direct access to a dvObject floating-point stored property value from its name
// - slightly faster than the variant-based Value[] default property
// - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options
// - use GetAsDouble if you want to check the availability of the field
// - D['prop'] := 1.23 would add a new property, or overwrite an existing
property D[const aName: RawUTF8]: Double read GetDoubleByName write SetDoubleByName;
/// direct access to a dvObject existing dvObject property from its name
// - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options
// - O['prop'] would return a fake void TDocVariant if the property is not
// existing or not a dvObject, just like GetAsDocVariantSafe()
// - use O_['prop'] to force adding any missing property
property O[const aName: RawUTF8]: PDocVariantData read GetObjectExistingByName;
/// direct access or add a dvObject's dvObject property from its name
// - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options
// - O_['prop'] would add a new property if there is none existing, or
// overwrite an existing property which is not a dvObject
property O_[const aName: RawUTF8]: PDocVariantData read GetObjectOrAddByName;
/// direct access to a dvObject existing dvArray property from its name
// - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options
// - A['prop'] would return a fake void TDocVariant if the property is not
// existing or not a dvArray, just like GetAsDocVariantSafe()
// - use A_['prop'] to force adding any missing property
property A[const aName: RawUTF8]: PDocVariantData read GetArrayExistingByName;
/// direct access or add a dvObject's dvArray property from its name
// - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options
// - A_['prop'] would add a new property if there is none existing, or
// overwrite an existing property which is not a dvArray
property A_[const aName: RawUTF8]: PDocVariantData read GetArrayOrAddByName;
/// direct access to a dvArray's TDocVariant property from its index
// - simple values may directly use Values[] dynamic array, but to access
// a TDocVariantData members, this property is safer
// - follows dvoReturnNullForUnknownProperty option to raise an exception
// - _[ndx] would return a fake void TDocVariant if aIndex is out of range,
// if the property is not existing or not a TDocVariantData (just like
// GetAsDocVariantSafe)
property _[aIndex: integer]: PDocVariantData read GetAsDocVariantByIndex;
end;
{$A+} { packet object not allowed since Delphi 2009 :( }
var
/// the internal custom variant type used to register TDocVariant
DocVariantType: TDocVariant = nil;
/// copy of DocVariantType.VarType
// - as used by inlined functions of TDocVariantData
DocVariantVType: integer = -1;
/// retrieve the text representation of a TDocVairnatKind
function ToText(kind: TDocVariantKind): PShortString; overload;
/// direct access to a TDocVariantData from a given variant instance
// - return a pointer to the TDocVariantData corresponding to the variant
// instance, which may be of kind varByRef (e.g. when retrieved by late binding)
// - raise an EDocVariant exception if the instance is not a TDocVariant
// - the following direct trans-typing may fail, e.g. for varByRef value:
// ! TDocVariantData(aVarDoc.ArrayProp).Add('new item');
// - so you can write the following:
// ! DocVariantData(aVarDoc.ArrayProp).AddItem('new item');
function DocVariantData(const DocVariant: variant): PDocVariantData;
const
/// constant used e.g. by _Safe() overloaded functions
// - will be in code section of the exe, so will be read-only by design
// - would have Kind=dvUndefined and Count=0, so _Safe() would return
// a valid, but void document
// - its VType is varNull, so would be viewed as a null variant
// - dvoReturnNullForUnknownProperty is defined, so that U[]/I[]... methods
// won't raise any exception about unexpected field name
DocVariantDataFake: TDocVariantData = (
VType:1; VOptions:[dvoReturnNullForUnknownProperty]);
/// direct access to a TDocVariantData from a given variant instance
// - return a pointer to the TDocVariantData corresponding to the variant
// instance, which may be of kind varByRef (e.g. when retrieved by late binding)
// - will return a read-only fake TDocVariantData with Kind=dvUndefined if the
// supplied variant is not a TDocVariant instance, so could be safely used
// in a with block (use "with" moderation, of course):
// ! with _Safe(aDocVariant)^ do
// ! for ndx := 0 to Count-1 do // here Count=0 for the "fake" result
// ! writeln(Names[ndx]);
// or excluding the "with" statement, as more readable code:
// ! var dv: PDocVariantData;
// ! ndx: PtrInt;
// ! begin
// ! dv := _Safe(aDocVariant);
// ! for ndx := 0 to dv.Count-1 do // here Count=0 for the "fake" result
// ! writeln(dv.Names[ndx]);
function _Safe(const DocVariant: variant): PDocVariantData; overload;
{$ifdef FPC}inline;{$endif} // Delphi has problems inlining this :(
/// direct access to a TDocVariantData from a given variant instance
// - return a pointer to the TDocVariantData corresponding to the variant
// instance, which may be of kind varByRef (e.g. when retrieved by late binding)
// - will check the supplied document kind, i.e. either dvObject or dvArray and
// raise a EDocVariant exception if it does not match
function _Safe(const DocVariant: variant; ExpectedKind: TDocVariantKind): PDocVariantData; overload;
/// initialize a variant instance to store some document-based object content
// - object will be initialized with data supplied two by two, as Name,Value
// pairs, e.g.
// ! aVariant := _Obj(['name','John','year',1972]);
// or even with nested objects:
// ! aVariant := _Obj(['name','John','doc',_Obj(['one',1,'two',2.0])]);
// - this global function is an alias to TDocVariant.NewObject()
// - by default, every internal value will be copied, so access of nested
// properties can be slow - if you expect the data to be read-only or not
// propagated into another place, set Options=[dvoValueCopiedByReference]
// or using _ObjFast() will increase the process speed a lot
function _Obj(const NameValuePairs: array of const;
Options: TDocVariantOptions=[]): variant;
/// add some property values to a document-based object content
// - if Obj is a TDocVariant object, will add the Name/Value pairs
// - if Obj is not a TDocVariant, will create a new fast document,
// initialized with supplied the Name/Value pairs
// - this function will also ensure that ensure Obj is not stored by reference,
// but as a true TDocVariantData
procedure _ObjAddProps(const NameValuePairs: array of const; var Obj: variant); overload;
/// add the property values of a document to a document-based object content
// - if Document is not a TDocVariant object, will do nothing
// - if Obj is a TDocVariant object, will add Document fields to its content
// - if Obj is not a TDocVariant object, Document will be copied to Obj
procedure _ObjAddProps(const Document: variant; var Obj: variant); overload;
/// initialize a variant instance to store some document-based array content
// - array will be initialized with data supplied as parameters, e.g.
// ! aVariant := _Arr(['one',2,3.0]);
// - this global function is an alias to TDocVariant.NewArray()
// - by default, every internal value will be copied, so access of nested
// properties can be slow - if you expect the data to be read-only or not
// propagated into another place, set Options=[dvoValueCopiedByReference]
// or using _ArrFast() will increase the process speed a lot
function _Arr(const Items: array of const;
Options: TDocVariantOptions=[]): variant;
/// initialize a variant instance to store some document-based content
// from a supplied (extended) JSON content
// - this global function is an alias to TDocVariant.NewJSON(), and
// will return an Unassigned variant if JSON content was not correctly converted
// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency
// - object or array will be initialized from the supplied JSON content, e.g.
// ! aVariant := _Json('{"id":10,"doc":{"name":"John","birthyear":1972}}');
// ! // now you can access to the properties via late binding
// ! assert(aVariant.id=10);
// ! assert(aVariant.doc.name='John');
// ! assert(aVariant.doc.birthYear=1972);
// ! // and also some pseudo-properties:
// ! assert(aVariant._count=2);
// ! assert(aVariant.doc._kind=ord(dvObject));
// ! // or with a JSON array:
// ! aVariant := _Json('["one",2,3]');
// ! assert(aVariant._kind=ord(dvArray));
// ! for i := 0 to aVariant._count-1 do
// ! writeln(aVariant._(i));
// - in addition to the JSON RFC specification strict mode, this method will
// handle some BSON-like extensions, e.g. unquoted field names:
// ! aVariant := _Json('{id:10,doc:{name:"John",birthyear:1972}}');
// - if the SynMongoDB unit is used in the application, the MongoDB Shell
// syntax will also be recognized to create TBSONVariant, like
// ! new Date() ObjectId() MinKey MaxKey /<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() /
// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency
// _Arr() instances as expected JSON objects / arrays
// - typical use (in the context of SynMongoDB unit) could be:
// ! aVariant := _JSONFmt('{%:{$in:[?,?]}}',['type'],['food','snack']);
// ! aVariant := _JSONFmt('{type:{$in:?}}',[],[_Arr(['food','snack'])]);
// ! // which are the same as:
// ! aVariant := _JSONFmt('{type:{$in:["food","snack"]}}');
// ! // in this context:
// ! u := VariantSaveJSON(aVariant);
// ! assert(u='{"type":{"$in":["food","snack"]}}');
// ! u := VariantSaveMongoJSON(aVariant,modMongoShell);
// ! assert(u='{type:{$in:["food","snack"]}}');
// - by default, every internal value will be copied, so access of nested
// properties can be slow - if you expect the data to be read-only or not
// propagated into another place, add dvoValueCopiedByReference in Options
// will increase the process speed a lot, or use _JsonFast()
function _JsonFmt(const Format: RawUTF8; const Args,Params: array of const;
Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant; overload;
/// initialize a variant instance to store some document-based content
// from a supplied (extended) JSON content, with parameters formating
// - this overload function will set directly a local variant variable,
// and would be used by inlined _JsonFmt/_JsonFastFmt functions
procedure _JsonFmt(const Format: RawUTF8; const Args,Params: array of const;
Options: TDocVariantOptions; out result: variant); overload;
/// initialize a variant instance to store some document-based content
// from a supplied (extended) JSON content
// - this global function is an alias to TDocVariant.NewJSON(), and
// will return TRUE if JSON content was correctly converted into a variant
// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency
// - in addition to the JSON RFC specification strict mode, this method will
// handle some BSON-like extensions, e.g. unquoted field names or ObjectID()
// - by default, every internal value will be copied, so access of nested
// properties can be slow - if you expect the data to be read-only or not
// propagated into another place, add dvoValueCopiedByReference in Options
// will increase the process speed a lot, or use _JsonFast()
function _Json(const JSON: RawUTF8; var Value: variant;
Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// initialize a variant instance to store some document-based object content
// - this global function is an handy alias to:
// ! Obj(NameValuePairs,JSON_OPTIONS[true]);
// - so all created objects and arrays will be handled by reference, for best
// speed - but you should better write on the resulting variant tree with caution
function _ObjFast(const NameValuePairs: array of const): variant; overload;
/// initialize a variant instance to store any object as a TDocVariant
// - is a wrapper around _JsonFast(ObjectToJson(aObject,aOptions))
function _ObjFast(aObject: TObject;
aOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]): variant; overload;
/// initialize a variant instance to store some document-based array content
// - this global function is an handy alias to:
// ! _Array(Items,JSON_OPTIONS[true]);
// - so all created objects and arrays will be handled by reference, for best
// speed - but you should better write on the resulting variant tree with caution
function _ArrFast(const Items: array of const): variant; overload;
/// initialize a variant instance to store some document-based content
// from a supplied (extended) JSON content
// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency
// - this global function is an handy alias to:
// ! _Json(JSON,JSON_OPTIONS[true]); or _Json(JSON,JSON_OPTIONS_FAST)
// so it will return an Unassigned variant if JSON content was not correct
// - so all created objects and arrays will be handled by reference, for best
// speed - but you should better write on the resulting variant tree with caution
// - in addition to the JSON RFC specification strict mode, this method will
// handle some BSON-like extensions, e.g. unquoted field names or ObjectID()
function _JsonFast(const JSON: RawUTF8): variant;
{$ifdef HASINLINE}inline;{$endif}
/// initialize a variant instance to store some document-based content
// from a supplied (extended) JSON content, parsing any kind of float
// - use JSON_OPTIONS_FAST_FLOAT including the dvoAllowDoubleValue option
function _JsonFastFloat(const JSON: RawUTF8): variant;
{$ifdef HASINLINE}inline;{$endif}
/// initialize a variant instance to store some extended document-based content
// - this global function is an handy alias to:
// ! _Json(JSON,JSON_OPTIONS_FAST_EXTENDED);
function _JsonFastExt(const JSON: RawUTF8): variant;
{$ifdef HASINLINE}inline;{$endif}
/// initialize a variant instance to store some document-based content
// from a supplied (extended) JSON content, with parameters formating
// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency
// - this global function is an handy alias e.g. to:
// ! aVariant := _JSONFmt('{%:{$in:[?,?]}}',['type'],['food','snack'],JSON_OPTIONS[true]);
// - so all created objects and arrays will be handled by reference, for best
// speed - but you should better write on the resulting variant tree with caution
// - in addition to the JSON RFC specification strict mode, this method will
// handle some BSON-like extensions, e.g. unquoted field names or ObjectID():
function _JsonFastFmt(const Format: RawUTF8; const Args,Params: array of const): variant;
/// ensure a document-based variant instance will have only per-value nested
// objects or array documents
// - is just a wrapper around:
// ! TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS[false])
// - you can use this function to ensure that all internal properties of this
// variant will be copied per-value whatever options the nested objects or
// arrays were created with
// - for huge document with a big depth of nested objects or arrays, a full
// per-value copy may be time and resource consuming, but will be also safe
// - will raise an EDocVariant if the supplied variant is not a TDocVariant or
// a varByRef pointing to a TDocVariant
procedure _Unique(var DocVariant: variant);
/// ensure a document-based variant instance will have only per-value nested
// objects or array documents
// - is just a wrapper around:
// ! TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS[true])
// - you can use this function to ensure that all internal properties of this
// variant will be copied per-reference whatever options the nested objects or
// arrays were created with
// - for huge document with a big depth of nested objects or arrays, it will
// first create a whole copy of the document nodes, but further assignments
// of the resulting value will be per-reference, so will be almost instant
// - will raise an EDocVariant if the supplied variant is not a TDocVariant or
// a varByRef pointing to a TDocVariant
procedure _UniqueFast(var DocVariant: variant);
/// return a full nested copy of a document-based variant instance
// - is just a wrapper around:
// ! TDocVariant.NewUnique(DocVariant,JSON_OPTIONS[false])
// - you can use this function to ensure that all internal properties of this
// variant will be copied per-value whatever options the nested objects or
// arrays were created with: to be used on a value returned as varByRef
// (e.g. by _() pseudo-method)
// - for huge document with a big depth of nested objects or arrays, a full
// per-value copy may be time and resource consuming, but will be also safe -
// consider using _ByRef() instead if a fast copy-by-reference is enough
// - will raise an EDocVariant if the supplied variant is not a TDocVariant or
// a varByRef pointing to a TDocVariant
function _Copy(const DocVariant: variant): variant;
{$ifdef HASINLINE}inline;{$endif}
/// return a full nested copy of a document-based variant instance
// - is just a wrapper around:
// ! TDocVariant.NewUnique(DocVariant,JSON_OPTIONS[true])
// - you can use this function to ensure that all internal properties of this
// variant will be copied per-value whatever options the nested objects or
// arrays were created with: to be used on a value returned as varByRef
// (e.g. by _() pseudo-method)
// - for huge document with a big depth of nested objects or arrays, a full
// per-value copy may be time and resource consuming, but will be also safe -
// consider using _ByRef() instead if a fast copy-by-reference is enough
// - will raise an EDocVariant if the supplied variant is not a TDocVariant or
// a varByRef pointing to a TDocVariant
function _CopyFast(const DocVariant: variant): variant;
{$ifdef HASINLINE}inline;{$endif}
/// copy a TDocVariant to another variable, changing the options on the fly
// - note that the content (items or properties) is copied by reference,
// so consider using _Copy() instead if you expect to safely modify its content
// - will return null if the supplied variant is not a TDocVariant
function _ByRef(const DocVariant: variant; Options: TDocVariantOptions): variant; overload;
/// copy a TDocVariant to another variable, changing the options on the fly
// - note that the content (items or properties) is copied by reference,
// so consider using _Copy() instead if you expect to safely modify its content
// - will return null if the supplied variant is not a TDocVariant
procedure _ByRef(const DocVariant: variant; out Dest: variant;
Options: TDocVariantOptions); overload;
/// convert a TDocVariantData array or a string value into a CSV
// - will call either TDocVariantData.ToCSV, or return the string
// - returns '' if the supplied value is neither a TDocVariant or a string
// - could be used e.g. to store either a JSON CSV string or a JSON array of
// strings in a settings property
function _CSV(const DocVariantOrString: variant): RawUTF8;
/// will convert any TObject into a TDocVariant document instance
// - a slightly faster alternative to Dest := _JsonFast(ObjectToJSON(Value))
// - this would convert the TObject by representation, using only serializable
// published properties: do not use this function to store temporary a class
// instance, but e.g. to store an object values in a NoSQL database
// - if you expect lazy-loading of a TObject, see TObjectVariant.New()
procedure ObjectToVariant(Value: TObject; out Dest: variant); overload;
{$ifdef HASINLINE}inline;{$endif}
/// will convert any TObject into a TDocVariant document instance
// - a faster alternative to _JsonFast(ObjectToJSON(Value))
// - if you expect lazy-loading of a TObject, see TObjectVariant.New()
function ObjectToVariant(Value: TObject; EnumSetsAsText: boolean=false): variant; overload;
/// will convert any TObject into a TDocVariant document instance
// - a faster alternative to _Json(ObjectToJSON(Value),Options)
// - note that the result variable should already be cleared: no VarClear()
// is done by this function
// - would be used e.g. by VarRecToVariant() function
// - if you expect lazy-loading of a TObject, see TObjectVariant.New()
procedure ObjectToVariant(Value: TObject; var result: variant;
Options: TTextWriterWriteObjectOptions); overload;
{$endif NOVARIANTS}
{ ******************* process monitoring / statistics ********************** }
type
/// the kind of value stored in a TSynMonitor / TSynMonitorUsage property
// - i.e. match TSynMonitorTotalMicroSec, TSynMonitorOneMicroSec,
// TSynMonitorOneCount, TSynMonitorOneBytes, TSynMonitorBytesPerSec,
// TSynMonitorTotalBytes, TSynMonitorCount and TSynMonitorCount64 types as
// used to store statistic information
// - "cumulative" values would sum each process values, e.g. total elapsed
// time for SOA execution, task count or total I/O bytes
// - "immediate" (e.g. svOneBytes or smvBytesPerSec) values would be an evolving
// single value, e.g. an average value or current disk free size
// - use SYNMONITORVALUE_CUMULATIVE = [smvMicroSec,smvBytes,smvCount,smvCount64]
// constant to identify the kind of value
// - TSynMonitorUsage.Track() would use MonitorPropUsageValue() to guess
// the tracked properties type from class RTTI
TSynMonitorType = (
smvUndefined, smvOneMicroSec, smvOneBytes, smvOneCount, smvBytesPerSec,
smvMicroSec, smvBytes, smvCount, smvCount64);
/// value types as stored in TSynMonitor / TSynMonitorUsage
TSynMonitorTypes = set of TSynMonitorType;
/// would identify a cumulative time process information in micro seconds, during monitoring
// - "cumulative" time would add each process timing, e.g. for statistics about
// SOA computation of a given service
// - any property defined with this type would be identified by TSynMonitorUsage
TSynMonitorTotalMicroSec = type QWord;
/// would identify an immediate time count information, during monitoring
// - "immediate" counts won't accumulate, e.g. may store the current number
// of thread used by a process
// - any property defined with this type would be identified by TSynMonitorUsage
TSynMonitorOneCount = type cardinal;
/// would identify an immediate time process information in micro seconds, during monitoring
// - "immediate" time won't accumulate, i.e. may store the duration of the
// latest execution of a SOA computation
// - any property defined with this type would be identified by TSynMonitorUsage
TSynMonitorOneMicroSec = type QWord;
/// would identify a process information as cumulative bytes count, during monitoring
// - "cumulative" size would add some byte for each process, e.g. input/output
// - any property defined with this type would be identified by TSynMonitorUsage
TSynMonitorTotalBytes = type QWord;
/// would identify an immediate process information as bytes count, during monitoring
// - "immediate" size won't accumulate, i.e. may be e.g. computer free memory
// at a given time
// - any property defined with this type would be identified by TSynMonitorUsage
TSynMonitorOneBytes = type QWord;
/// would identify the process throughput, during monitoring
// - it indicates e.g. "immediate" bandwith usage
// - any property defined with this type would be identified by TSynMonitorUsage
TSynMonitorBytesPerSec = type QWord;
/// would identify a cumulative number of processes, during monitoring
// - any property defined with this type would be identified by TSynMonitorUsage
TSynMonitorCount = type cardinal;
/// would identify a cumulative number of processes, during monitoring
// - any property defined with this type would be identified by TSynMonitorUsage
TSynMonitorCount64 = type QWord;
/// pointer to a high resolution timer object/record
PPrecisionTimer = ^TPrecisionTimer;
/// indirect reference to a pointer to a high resolution timer object/record
PPPrecisionTimer = ^PPrecisionTimer;
/// high resolution timer (for accurate speed statistics)
// - WARNING: under Windows, this record MUST be aligned to 32-bit, otherwise
// iFreq=0 - so you can use TLocalPrecisionTimer/ILocalPrecisionTimer if you
// want to alllocate a local timer instance on the stack
TPrecisionTimer = object
protected
fStart,fStop: Int64;
{$ifndef LINUX} // use QueryPerformanceMicroSeconds() fast API
fWinFreq: Int64;
{$endif}
/// contains the time elapsed in micro seconds between Start and Stop
fTime: TSynMonitorTotalMicroSec;
/// contains the time elapsed in micro seconds between Resume and Pause
fLastTime: TSynMonitorOneMicroSec;
fPauseCount: TSynMonitorCount;
public
/// initialize the timer
// - will fill all internal state with 0
// - not necessary e.g. if TPrecisionTimer is defined as a TObject field
procedure Init; {$ifdef HASINLINE}inline;{$endif}
/// initialize and start the high resolution timer
// - similar to Init + Resume
procedure Start;
/// stop the timer, returning the total time elapsed as text
// - with appended time resolution (us,ms,s) - from MicroSecToString()
// - is just a wrapper around Pause + Time
// - you can call Resume to continue adding time to this timer
function Stop: TShort16; {$ifdef HASINLINE}inline;{$endif}
/// stop the timer, returning the total time elapsed as microseconds
// - is just a wrapper around Pause + Time
// - you can call Resume to continue adding time to this timer
function StopInMicroSec: TSynMonitorTotalMicroSec; {$ifdef HASINLINE}inline;{$endif}
/// stop the timer, ready to continue its time measurement via Resume
// - will also compute the global Time value
// - do nothing if no previous Start/Resume call is pending
procedure Pause;
/// resume a paused timer, or start an initialized timer
// - do nothing if no timer has been initialized or paused just before
// - if the previous method called was Init, will act like Start
// - if the previous method called was Pause, it will continue counting
procedure Resume; {$ifdef HASINLINE}inline;{$endif}
/// resume a paused timer until the method ends
// - will internaly create a TInterfaceObject class to let the compiler
// generate a try..finally block as expected to call Pause at method ending
// - is therefore very convenient to have consistent Resume/Pause calls
// - for proper use, expect TPrecisionTimer to be initialized to 0 before
// execution (e.g. define it as a protected member of a class)
// - typical use is to declare a fTimeElapsed: TPrecisionTimer protected
// member, then call fTimeElapsed.ProfileCurrentMethod at the beginning of
// all process expecting some timing, then log/save fTimeElapsed.Stop content
// - FPC TIP: result should be assigned to a local variable of IUnknown type
function ProfileCurrentMethod: IUnknown;
/// low-level method to force values settings to allow thread safe timing
// - by default, this timer is not thread safe: you can use this method to
// set the timing values from manually computed performance counters
// - the caller should also use a mutex to prevent from race conditions:
// see e.g. TSynMonitor.FromExternalMicroSeconds implementation
// - warning: Start, Stop, Pause and Resume methods are then disallowed
procedure FromExternalMicroSeconds(const MicroSeconds: QWord);
{$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell
/// low-level method to force values settings to allow thread safe timing
// - by default, this timer is not thread safe: you can use this method to
// set the timing values from manually computed performance counters
// - the caller should also use a mutex to prevent from race conditions:
// see e.g. TSynMonitor.FromExternalQueryPerformanceCounters implementation
// - returns the time elapsed, in micro seconds (i.e. LastTime value)
// - warning: Start, Stop, Pause and Resume methods are then disallowed
function FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord;
{$ifdef FPCLINUX}inline;{$endif}
/// compute the per second count
function PerSec(const Count: QWord): QWord;
/// compute the time elapsed by count, with appened time resolution (us,ms,s)
function ByCount(Count: QWord): TShort16;
/// returns e.g. '16.9 MB in 102.20ms i.e. 165.5 MB/s'
function SizePerSec(Size: QWord): shortstring;
/// textual representation of total time elapsed
// - with appened time resolution (us,ms,s) - from MicroSecToString()
// - not to be used in normal code (which could rather call the Stop method),
// but e.g. for custom performance analysis
function Time: TShort16;
/// textual representation of last process timing after counter stopped
// - Time returns a total elapsed time, whereas this method only returns
// the latest resumed time
// - with appened time resolution (us,ms,s) - from MicroSecToString()
// - not to be used in normal code, but e.g. for custom performance analysis
function LastTime: TShort16;
/// check if Start/Resume were called at least once
function Started: boolean;
/// time elapsed in micro seconds after counter stopped
// - not to be used in normal code, but e.g. for custom performance analysis
property TimeInMicroSec: TSynMonitorTotalMicroSec read fTime write fTime;
/// timing in micro seconds of the last process
// - not to be used in normal code, but e.g. for custom performance analysis
property LastTimeInMicroSec: TSynMonitorOneMicroSec read fLastTime write fLastTime;
/// how many times the Pause method was called, i.e. the number of tasks
// processeed
property PauseCount: TSynMonitorCount read fPauseCount;
end;
/// interface to a reference counted high resolution timer instance
// - implemented by TLocalPrecisionTimer
ILocalPrecisionTimer = interface
/// start the high resolution timer
procedure Start;
/// stop the timer, returning the time elapsed, with appened time resolution (us,ms,s)
function Stop: TShort16;
/// stop the timer, ready to continue its time measure
procedure Pause;
/// resume a paused timer, or start it if it hasn't be started
procedure Resume;
/// compute the per second count
function PerSec(Count: cardinal): cardinal;
/// compute the time elapsed by count, with appened time resolution (us,ms,s)
function ByCount(Count: cardinal): RawUTF8;
end;
/// reference counted high resolution timer (for accurate speed statistics)
// - since TPrecisionTimer shall be 32-bit aligned, you can use this class
// to initialize a local auto-freeing ILocalPrecisionTimer variable on stack
// - to be used as such:
// ! var Timer: ILocalPrecisionTimer;
// ! (...)
// ! Timer := TLocalPrecisionTimer.Create;
// ! Timer.Start;
// ! (...)
TLocalPrecisionTimer = class(TInterfacedObject,ILocalPrecisionTimer)
protected
fTimer: TPrecisionTimer;
public
/// initialize the instance, and start the high resolution timer
constructor CreateAndStart;
/// start the high resolution timer
procedure Start;
/// stop the timer, returning the time elapsed, with appened time resolution (us,ms,s)
function Stop: TShort16;
/// stop the timer, ready to continue its time measure
procedure Pause;
/// resume a paused timer, or start the timer
procedure Resume;
/// compute the per second count
function PerSec(Count: cardinal): cardinal;
/// compute the time elapsed by count, with appened time resolution (us,ms,s)
function ByCount(Count: cardinal): RawUTF8;
end;
/// able to serialize any cumulative timing as raw micro-seconds number or text
// - "cumulative" time would add each process value, e.g. SOA methods execution
TSynMonitorTime = class(TSynPersistent)
protected
fMicroSeconds: TSynMonitorTotalMicroSec;
function GetAsText: TShort16;
public
/// compute a number per second, of the current value
function PerSecond(const Count: QWord): QWord;
{$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell
published
/// micro seconds time elapsed, as raw number
property MicroSec: TSynMonitorTotalMicroSec read fMicroSeconds write fMicroSeconds;
/// micro seconds time elapsed, as '... us-ns-ms-s' text
property Text: TShort16 read GetAsText;
end;
/// able to serialize any immediate timing as raw micro-seconds number or text
// - "immediate" size won't accumulate, i.e. may be e.g. last process time
TSynMonitorOneTime = class(TSynPersistent)
protected
fMicroSeconds: TSynMonitorOneMicroSec;
function GetAsText: TShort16;
public
/// compute a number per second, of the current value
function PerSecond(const Count: QWord): QWord;
{$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell
published
/// micro seconds time elapsed, as raw number
property MicroSec: TSynMonitorOneMicroSec read fMicroSeconds write fMicroSeconds;
/// micro seconds time elapsed, as '... us-ns-ms-s' text
property Text: TShort16 read GetAsText;
end;
TSynMonitorSizeParent = class(TSynPersistent)
protected
fTextNoSpace: boolean;
public
/// initialize the instance
constructor Create(aTextNoSpace: boolean); reintroduce;
end;
/// able to serialize any cumulative size as bytes number
// - "cumulative" time would add each process value, e.g. global IO consumption
TSynMonitorSize = class(TSynMonitorSizeParent)
protected
fBytes: TSynMonitorTotalBytes;
function GetAsText: TShort16;
published
/// number of bytes, as raw number
property Bytes: TSynMonitorTotalBytes read fBytes write fBytes;
/// number of bytes, as '... B-KB-MB-GB' text
property Text: TShort16 read GetAsText;
end;
/// able to serialize any immediate size as bytes number
// - "immediate" size won't accumulate, i.e. may be e.g. computer free memory
// at a given time
TSynMonitorOneSize = class(TSynMonitorSizeParent)
protected
fBytes: TSynMonitorOneBytes;
function GetAsText: TShort16;
published
/// number of bytes, as raw number
property Bytes: TSynMonitorOneBytes read fBytes write fBytes;
/// number of bytes, as '... B-KB-MB-GB' text
property Text: TShort16 read GetAsText;
end;
/// able to serialize any bandwith as bytes count per second
// - is usually associated with TSynMonitorOneSize properties,
// e.g. to monitor IO activity
TSynMonitorThroughput = class(TSynMonitorSizeParent)
protected
fBytesPerSec: QWord;
function GetAsText: TShort16;
published
/// number of bytes per second, as raw number
property BytesPerSec: QWord read fBytesPerSec write fBytesPerSec;
/// number of bytes per second, as '... B-KB-MB-GB/s' text
property Text: TShort16 read GetAsText;
end;
/// a generic value object able to handle any task / process statistic
// - base class shared e.g. for ORM, SOA or DDD, when a repeatable data
// process is to be monitored
// - this class is thread-safe for its methods, but you should call explicitly
// Lock/UnLock to access its individual properties
TSynMonitor = class(TSynPersistentLock)
protected
fName: RawUTF8;
fTaskCount: TSynMonitorCount64;
fTotalTime: TSynMonitorTime;
fLastTime: TSynMonitorOneTime;
fMinimalTime: TSynMonitorOneTime;
fAverageTime: TSynMonitorOneTime;
fMaximalTime: TSynMonitorOneTime;
fPerSec: QWord;
fInternalErrors: TSynMonitorCount;
fProcessing: boolean;
fTaskStatus: (taskNotStarted,taskStarted);
fLastInternalError: variant;
procedure LockedPerSecProperties; virtual;
procedure LockedFromProcessTimer; virtual;
procedure LockedSum(another: TSynMonitor); virtual;
procedure WriteDetailsTo(W: TTextWriter); virtual;
procedure Changed; virtual;
public
/// low-level high-precision timer instance
InternalTimer: TPrecisionTimer;
/// initialize the instance nested class properties
// - you can specify identifier associated to this monitored resource
// which would be used for TSynMonitorUsage persistence
constructor Create(const aName: RawUTF8); reintroduce; overload; virtual;
/// initialize the instance nested class properties
constructor Create; overload; override;
/// finalize the instance
destructor Destroy; override;
/// lock the instance for exclusive access
// - needed only if you access directly the instance properties
procedure Lock; {$ifdef HASINLINE}inline;{$endif}
/// release the instance for exclusive access
// - needed only if you access directly the instance properties
procedure UnLock; {$ifdef HASINLINE}inline;{$endif}
/// create Count instances of this actual class in the supplied ObjArr[]
class procedure InitializeObjArray(var ObjArr; Count: integer); virtual;
/// should be called when the process starts, to resume the internal timer
// - thread-safe method
procedure ProcessStart; virtual;
/// should be called each time a pending task is processed
// - will increase the TaskCount property
// - thread-safe method
procedure ProcessDoTask; virtual;
/// should be called when the process starts, and a task is processed
// - similar to ProcessStart + ProcessDoTask
// - thread-safe method
procedure ProcessStartTask; virtual;
/// should be called when an error occurred
// - typical use is with ObjectToVariantDebug(E,...) kind of information
// - thread-safe method
procedure ProcessError(const info: variant); virtual;
/// should be called when an error occurred
// - typical use is with a HTTP status, e.g. as ProcessError(Call.OutStatus)
// - just a wraper around overloaded ProcessError(), so a thread-safe method
procedure ProcessErrorNumber(info: integer);
/// should be called when an error occurred
// - just a wraper around overloaded ProcessError(), so a thread-safe method
procedure ProcessErrorFmt(const Fmt: RawUTF8; const Args: array of const);
/// should be called when an Exception occurred
// - just a wraper around overloaded ProcessError(), so a thread-safe method
procedure ProcessErrorRaised(E: Exception);
/// should be called when the process stops, to pause the internal timer
// - thread-safe method
procedure ProcessEnd; virtual;
/// could be used to manage information average or sums
// - thread-safe method calling LockedSum protected virtual method
procedure Sum(another: TSynMonitor);
/// returns a JSON content with all published properties information
// - thread-safe method
function ComputeDetailsJSON: RawUTF8;
/// appends a JSON content with all published properties information
// - thread-safe method
procedure ComputeDetailsTo(W: TTextWriter); virtual;
{$ifndef NOVARIANTS}
/// returns a TDocVariant with all published properties information
// - thread-safe method
function ComputeDetails: variant;
{$endif NOVARIANTS}
/// used to allow thread safe timing
// - by default, the internal TPrecisionTimer is not thread safe: you can
// use this method to update the timing from many threads
// - if you use this method, ProcessStart, ProcessDoTask and ProcessEnd
// methods are disallowed, and the global fTimer won't be used any more
// - will return the processing time, converted into micro seconds, ready
// to be logged if needed
// - thread-safe method
function FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord;
/// used to allow thread safe timing
// - by default, the internal TPrecisionTimer is not thread safe: you can
// use this method to update the timing from many threads
// - if you use this method, ProcessStart, ProcessDoTask and ProcessEnd
// methods are disallowed, and the global fTimer won't be used any more
// - thread-safe method
procedure FromExternalMicroSeconds(const MicroSecondsElapsed: QWord);
/// an identifier associated to this monitored resource
// - is used e.g. for TSynMonitorUsage persistence/tracking
property Name: RawUTF8 read fName write fName;
published
/// indicates if this thread is currently working on some process
property Processing: boolean read fProcessing write fProcessing;
/// how many times the task was performed
property TaskCount: TSynMonitorCount64 read fTaskCount write fTaskCount;
/// the whole time spend during all working process
property TotalTime: TSynMonitorTime read fTotalTime;
/// the time spend during the last task processing
property LastTime: TSynMonitorOneTime read fLastTime;
/// the lowest time spent during any working process
property MinimalTime: TSynMonitorOneTime read fMinimalTime;
/// the time spent in average during any working process
property AverageTime: TSynMonitorOneTime read fAverageTime;
/// the highest time spent during any working process
property MaximalTime: TSynMonitorOneTime read fMaximalTime;
/// average of how many tasks did occur per second
property PerSec: QWord read fPerSec;
/// how many errors did occur during the processing
property Errors: TSynMonitorCount read fInternalErrors;
/// information about the last error which occured during the processing
property LastError: variant read fLastInternalError;
end;
/// references a TSynMonitor instance
PSynMonitor = ^TSynMonitor;
/// handle generic process statistic with a processing data size and bandwitdh
TSynMonitorWithSize = class(TSynMonitor)
protected
fSize: TSynMonitorSize;
fThroughput: TSynMonitorThroughput;
procedure LockedPerSecProperties; override;
procedure LockedSum(another: TSynMonitor); override;
public
/// initialize the instance nested class properties
constructor Create; override;
/// finalize the instance
destructor Destroy; override;
/// increase the internal size counter
// - thread-safe method
procedure AddSize(const Bytes: QWord);
published
/// how many total data has been hanlded during all working process
property Size: TSynMonitorSize read fSize;
/// data processing bandwith, returned as B/KB/MB per second
property Throughput: TSynMonitorThroughput read fThroughput;
end;
/// handle generic process statistic with a incoming and outgoing processing
// data size and bandwitdh
TSynMonitorInputOutput = class(TSynMonitor)
protected
fInput: TSynMonitorSize;
fOutput: TSynMonitorSize;
fInputThroughput: TSynMonitorThroughput;
fOutputThroughput: TSynMonitorThroughput;
procedure LockedPerSecProperties; override;
procedure LockedSum(another: TSynMonitor); override;
public
/// initialize the instance nested class properties
constructor Create; override;
/// finalize the instance
destructor Destroy; override;
/// increase the internal size counters
// - thread-safe method
procedure AddSize(const Incoming, Outgoing: QWord);
published
/// how many data has been received
property Input: TSynMonitorSize read fInput;
/// how many data has been sent back
property Output: TSynMonitorSize read fOutput;
/// incoming data processing bandwith, returned as B/KB/MB per second
property InputThroughput: TSynMonitorThroughput read fInputThroughput;
/// outgoing data processing bandwith, returned as B/KB/MB per second
property OutputThroughput: TSynMonitorThroughput read fOutputThroughput;
end;
/// could monitor a standard Server
// - including Input/Output statistics and connected Clients count
TSynMonitorServer = class(TSynMonitorInputOutput)
protected
fCurrentRequestCount: integer;
fClientsCurrent: TSynMonitorOneCount;
fClientsMax: TSynMonitorOneCount;
public
/// update ClientsCurrent and ClientsMax
// - thread-safe method
procedure ClientConnect;
/// update ClientsCurrent and ClientsMax
// - thread-safe method
procedure ClientDisconnect;
/// update ClientsCurrent to 0
// - thread-safe method
procedure ClientDisconnectAll;
/// retrieve the number of connected clients
// - thread-safe method
function GetClientsCurrent: TSynMonitorOneCount;
/// how many concurrent requests are currently processed
// - returns the updated number of requests
// - thread-safe method
function AddCurrentRequestCount(diff: integer): integer;
published
/// current count of connected clients
property ClientsCurrent: TSynMonitorOneCount read fClientsCurrent;
/// max count of connected clients
property ClientsMax: TSynMonitorOneCount read fClientsMax;
/// how many concurrent requests are currently processed
// - modified via AddCurrentRequestCount() in TSQLRestServer.URI()
property CurrentRequestCount: integer read fCurrentRequestCount;
end;
/// a list of simple process statistics
TSynMonitorObjArray = array of TSynMonitor;
/// a list of data process statistics
TSynMonitorWithSizeObjArray = array of TSynMonitorWithSize;
/// a list of incoming/outgoing data process statistics
TSynMonitorInputOutputObjArray = array of TSynMonitorInputOutput;
/// class-reference type (metaclass) of a process statistic information
TSynMonitorClass = class of TSynMonitor;
{ ******************* cross-cutting classes and functions ***************** }
type
/// an abstract ancestor, for implementing a custom TInterfacedObject like class
// - by default, will do nothing: no instance would be retrieved by
// QueryInterface unless the VirtualQueryInterface protected method is
// overriden, and _AddRef/_Release methods would call VirtualAddRef and
// VirtualRelease pure abstract methods
// - using this class will leverage the signature difference between Delphi
// and FPC, among all supported platforms
// - the class includes a RefCount integer field
TSynInterfacedObject = class(TObject,IUnknown)
protected
fRefCount: integer;
// returns E_NOINTERFACE
function VirtualQueryInterface(const IID: TGUID; out Obj): HResult; virtual;
// always return 1 for a "non allocated" instance (0 triggers release)
function VirtualAddRef: Integer; virtual; abstract;
function VirtualRelease: Integer; virtual; abstract;
{$ifdef FPC}
function QueryInterface(
{$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID;
out Obj): longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _AddRef: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _Release: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
{$else}
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
{$endif}
public
/// the associated reference count
property RefCount: integer read fRefCount write fRefCount;
end;
{$ifdef CPUINTEL}
{$ifndef DELPHI5OROLDER}
/// a simple class which will set FPU exception flags for a code block
// - using an IUnknown interface to let the compiler auto-generate a
// try..finally block statement to reset the FPU exception register
// - to be used e.g. as such:
// !begin
// ! TSynFPUException.ForLibrayCode;
// ! ... now FPU exceptions will be ignored
// ! ... so here it is safe to call external libray code
// !end; // now FPU exception will be reset as with standard Delphi
// - it will avoid any unexpected invalid floating point operation in Delphi
// code, whereas it was in fact triggerred in some external library code
TSynFPUException = class(TSynInterfacedObject)
protected
{$ifndef CPU64}
fExpected8087, fSaved8087: word;
{$else}
fExpectedMXCSR, fSavedMXCSR: word;
{$endif}
function VirtualAddRef: Integer; override;
function VirtualRelease: Integer; override;
public
/// internal constructor
// - do not call this constructor directly, but rather use
// ForLibraryCode/ForDelphiCode class methods
// - for cpu32 flags are $1372 for Delphi, or $137F for library (mask all exceptions)
// - for cpu64 flags are $1920 for Delphi, or $1FA0 for library (mask all exceptions)
{$ifndef CPU64}
constructor Create(Expected8087Flag: word); reintroduce;
{$else}
constructor Create(ExpectedMXCSR: word); reintroduce;
{$endif}
/// after this method call, all FPU exceptions will be ignored
// - until the method finishes (a try..finally block is generated by
// the compiler), then FPU exceptions will be reset into "Delphi" mode
// - you have to put this e.g. before calling an external libray
// - this method is thread-safe and re-entrant (by reference-counting)
class function ForLibraryCode: IUnknown;
/// after this method call, all FPU exceptions will be enabled
// - this is the Delphi normal behavior
// - until the method finishes (a try..finally block is generated by
// the compiler), then FPU execptions will be disabled again
// - you have to put this e.g. before running an Delphi code from
// a callback executed in an external libray
// - this method is thread-safe and re-entrant (by reference-counting)
class function ForDelphiCode: IUnknown;
end;
{$endif DELPHI5OROLDER}
{$endif CPUINTEL}
/// interface for TAutoFree to register another TObject instance
// to an existing IAutoFree local variable
IAutoFree = interface
procedure Another(var objVar; obj: TObject);
end;
/// simple reference-counted storage for local objects
// - WARNING: both FPC and Delphi 10.4+ don't keep the IAutoFree instance
// up to the end-of-method -> you should not use TAutoFree for new projects
// :( - see https://quality.embarcadero.com/browse/RSP-30050
// - be aware that it won't implement a full ARC memory model, but may be
// just used to avoid writing some try ... finally blocks on local variables
// - use with caution, only on well defined local scope
TAutoFree = class(TInterfacedObject,IAutoFree)
protected
fObject: TObject;
fObjectList: array of TObject;
public
/// initialize the TAutoFree class for one local variable
// - do not call this constructor, but class function One() instead
constructor Create(var localVariable; obj: TObject); reintroduce; overload;
/// initialize the TAutoFree class for several local variables
// - do not call this constructor, but class function Several() instead
constructor Create(const varObjPairs: array of pointer); reintroduce; overload;
/// protect one local TObject variable instance life time
// - for instance, instead of writing:
// !var myVar: TMyClass;
// !begin
// ! myVar := TMyClass.Create;
// ! try
// ! ... use myVar
// ! finally
// ! myVar.Free;
// ! end;
// !end;
// - you may write:
// !var myVar: TMyClass;
// !begin
// ! TAutoFree.One(myVar,TMyClass.Create);
// ! ... use myVar
// !end; // here myVar will be released
// - warning: under FPC, you should assign the result of this method to a local
// IAutoFree variable - see bug http://bugs.freepascal.org/view.php?id=26602
// - Delphi 10.4 also did change it and release the IAutoFree before the
// end of the current method, so you should better use a local variable
class function One(var localVariable; obj: TObject): IAutoFree;
/// protect several local TObject variable instances life time
// - specified as localVariable/objectInstance pairs
// - you may write:
// !var var1,var2: TMyClass;
// !begin
// ! TAutoFree.Several([
// ! @var1,TMyClass.Create,
// ! @var2,TMyClass.Create]);
// ! ... use var1 and var2
// !end; // here var1 and var2 will be released
// - warning: under FPC, you should assign the result of this method to a local
// IAutoFree variable - see bug http://bugs.freepascal.org/view.php?id=26602
// - Delphi 10.4 also did change it and release the IAutoFree before the
// end of the current method, so you should better use a local variable
class function Several(const varObjPairs: array of pointer): IAutoFree;
/// protect another TObject variable to an existing IAutoFree instance life time
// - you may write:
// !var var1,var2: TMyClass;
// ! auto: IAutoFree;
// !begin
// ! auto := TAutoFree.One(var1,TMyClass.Create);,
// ! .... do something
// ! auto.Another(var2,TMyClass.Create);
// ! ... use var1 and var2
// !end; // here var1 and var2 will be released
procedure Another(var localVariable; obj: TObject);
/// will finalize the associated TObject instances
// - note that releasing the TObject instances won't be protected, so
// any exception here may induce a memory leak: use only with "safe"
// simple objects, e.g. mORMot's TSQLRecord
destructor Destroy; override;
end;
{$ifdef DELPHI5OROLDER} // IAutoLocker -> internal error C3517 under Delphi 5 :(
TAutoLocker = class
protected
fSafe: TSynLocker;
public
constructor Create;
destructor Destroy; override;
procedure Enter; virtual;
procedure Leave; virtual;
function ProtectMethod: IUnknown;
/// gives an access to the internal low-level TSynLocker instance used
function Safe: PSynLocker;
property Locker: TSynLocker read fSafe;
end;
IAutoLocker = TAutoLocker;
{$else DELPHI5OROLDER}
/// an interface used by TAutoLocker to protect multi-thread execution
IAutoLocker = interface
['{97559643-6474-4AD3-AF72-B9BB84B4955D}']
/// enter the mutex
// - any call to Enter should be ended with a call to Leave, and
// protected by a try..finally block, as such:
// !begin
// ! ... // unsafe code
// ! fSharedAutoLocker.Enter;
// ! try
// ! ... // thread-safe code
// ! finally
// ! fSharedAutoLocker.Leave;
// ! end;
// !end;
procedure Enter;
/// leave the mutex
// - any call to Leave should be preceded with a call to Enter
procedure Leave;
/// will enter the mutex until the IUnknown reference is released
// - using an IUnknown interface to let the compiler auto-generate a
// try..finally block statement to release the lock for the code block
// - could be used as such under Delphi:
// !begin
// ! ... // unsafe code
// ! fSharedAutoLocker.ProtectMethod;
// ! ... // thread-safe code
// !end; // local hidden IUnknown will release the lock for the method
// - warning: under FPC, you should assign its result to a local variable -
// see bug http://bugs.freepascal.org/view.php?id=26602
// !var LockFPC: IUnknown;
// !begin
// ! ... // unsafe code
// ! LockFPC := fSharedAutoLocker.ProtectMethod;
// ! ... // thread-safe code
// !end; // LockFPC will release the lock for the method
// or
// !begin
// ! ... // unsafe code
// ! with fSharedAutoLocker.ProtectMethod do begin
// ! ... // thread-safe code
// ! end; // local hidden IUnknown will release the lock for the method
// !end;
function ProtectMethod: IUnknown;
/// gives an access to the internal low-level TSynLocker instance used
function Safe: PSynLocker;
end;
/// reference-counted block code critical section
// - you can use one instance of this to protect multi-threaded execution
// - the main class may initialize a IAutoLocker property in Create, then call
// IAutoLocker.ProtectMethod in any method to make its execution thread safe
// - this class inherits from TInterfacedObjectWithCustomCreate so you
// could define one published property of a mORMot.pas' TInjectableObject
// as IAutoLocker so that this class may be automatically injected
// - you may use the inherited TAutoLockerDebug class, as defined in SynLog.pas,
// to debug unexpected race conditions due to such critical sections
// - consider inherit from high-level TSynPersistentLock or call low-level
// fSafe := NewSynLocker / fSafe^.DoneAndFreemem instead
TAutoLocker = class(TInterfacedObjectWithCustomCreate,IAutoLocker)
protected
fSafe: TSynLocker;
public
/// initialize the mutex
constructor Create; override;
/// finalize the mutex
destructor Destroy; override;
/// will enter the mutex until the IUnknown reference is released
// - as expected by IAutoLocker interface
// - could be used as such under Delphi:
// !begin
// ! ... // unsafe code
// ! fSharedAutoLocker.ProtectMethod;
// ! ... // thread-safe code
// !end; // local hidden IUnknown will release the lock for the method
// - warning: under FPC, you should assign its result to a local variable -
// see bug http://bugs.freepascal.org/view.php?id=26602
// !var LockFPC: IUnknown;
// !begin
// ! ... // unsafe code
// ! LockFPC := fSharedAutoLocker.ProtectMethod;
// ! ... // thread-safe code
// !end; // LockFPC will release the lock for the method
// or
// !begin
// ! ... // unsafe code
// ! with fSharedAutoLocker.ProtectMethod do begin
// ! ... // thread-safe code
// ! end; // local hidden IUnknown will release the lock for the method
// !end;
function ProtectMethod: IUnknown;
/// enter the mutex
// - as expected by IAutoLocker interface
// - any call to Enter should be ended with a call to Leave, and
// protected by a try..finally block, as such:
// !begin
// ! ... // unsafe code
// ! fSharedAutoLocker.Enter;
// ! try
// ! ... // thread-safe code
// ! finally
// ! fSharedAutoLocker.Leave;
// ! end;
// !end;
procedure Enter; virtual;
/// leave the mutex
// - as expected by IAutoLocker interface
procedure Leave; virtual;
/// access to the locking methods of this instance
// - as expected by IAutoLocker interface
function Safe: PSynLocker;
/// direct access to the locking methods of this instance
// - faster than IAutoLocker.Safe function
property Locker: TSynLocker read fSafe;
end;
{$endif DELPHI5OROLDER}
{$ifndef DELPHI5OROLDER} // internal error C3517 under Delphi 5 :(
{$ifndef NOVARIANTS}
/// ref-counted interface for thread-safe access to a TDocVariant document
// - is implemented e.g. by TLockedDocVariant, for IoC/DI resolution
// - fast and safe storage of any JSON-like object, as property/value pairs,
// or a JSON-like array, as values
ILockedDocVariant = interface
['{CADC2C20-3F5D-4539-9D23-275E833A86F3}']
function GetValue(const Name: RawUTF8): Variant;
procedure SetValue(const Name: RawUTF8; const Value: Variant);
/// check and return a given property by name
// - returns TRUE and fill Value with the value associated with the supplied
// Name, using an internal lock for thread-safety
// - returns FALSE if the Name was not found, releasing the internal lock:
// use ExistsOrLock() if you want to add the missing value
function Exists(const Name: RawUTF8; out Value: Variant): boolean;
/// check and return a given property by name
// - returns TRUE and fill Value with the value associated with the supplied
// Name, using an internal lock for thread-safety
// - returns FALSE and set the internal lock if Name does not exist:
// caller should then release the lock via ReplaceAndUnlock()
function ExistsOrLock(const Name: RawUTF8; out Value: Variant): boolean;
/// set a value by property name, and set a local copy
// - could be used as such, for implementing a thread-safe cache:
// ! if not cache.ExistsOrLock('prop',local) then
// ! cache.ReplaceAndUnlock('prop',newValue,local);
// - call of this method should have been precedeed by ExistsOrLock()
// returning false, i.e. be executed on a locked instance
procedure ReplaceAndUnlock(const Name: RawUTF8; const Value: Variant; out LocalValue: Variant);
/// add an existing property value to the given TDocVariant document object
// - returns TRUE and add the Name/Value pair to Obj if Name is existing,
// using an internal lock for thread-safety
// - returns FALSE if Name is not existing in the stored document, and
// lock the internal storage: caller should eventually release the lock
// via AddNewPropAndUnlock()
// - could be used as such, for implementing a thread-safe cache:
// ! if not cache.AddExistingPropOrLock('Articles',Scope) then
// ! cache.AddNewPropAndUnlock('Articles',GetArticlesFromDB,Scope);
// here GetArticlesFromDB would occur inside the main lock
function AddExistingPropOrLock(const Name: RawUTF8; var Obj: variant): boolean;
/// add a property value to the given TDocVariant document object and
// to the internal stored document, then release a previous lock
// - call of this method should have been precedeed by AddExistingPropOrLock()
// returning false, i.e. be executed on a locked instance
procedure AddNewPropAndUnlock(const Name: RawUTF8; const Value: variant; var Obj: variant);
/// add an existing property value to the given TDocVariant document object
// - returns TRUE and add the Name/Value pair to Obj if Name is existing
// - returns FALSE if Name is not existing in the stored document
// - this method would use a lock during the Name lookup, but would always
// release the lock, even if returning FALSE (see AddExistingPropOrLock)
function AddExistingProp(const Name: RawUTF8; var Obj: variant): boolean;
/// add a property value to the given TDocVariant document object
// - this method would not expect the resource to be locked when called,
// as with AddNewPropAndUnlock
// - will use the internal lock for thread-safety
// - if the Name is already existing, would update/change the existing value
// - could be used as such, for implementing a thread-safe cache:
// ! if not cache.AddExistingProp('Articles',Scope) then
// ! cache.AddNewProp('Articles',GetArticlesFromDB,Scope);
// here GetArticlesFromDB would occur outside the main lock
procedure AddNewProp(const Name: RawUTF8; const Value: variant; var Obj: variant);
/// append a value to the internal TDocVariant document array
// - you should not use this method in conjunction with other document-based
// alternatives, like Exists/AddExistingPropOrLock or AddExistingProp
procedure AddItem(const Value: variant);
/// makes a thread-safe copy of the internal TDocVariant document object or array
function Copy: variant;
/// delete all stored properties
procedure Clear;
/// save the stored values as UTF-8 encoded JSON Object
function ToJSON(HumanReadable: boolean=false): RawUTF8;
/// low-level access to the associated thread-safe mutex
function Lock: TAutoLocker;
/// the document fields would be safely accessed via this property
// - this is the main entry point of this storage
// - will raise an EDocVariant exception if Name does not exist at reading
// - implementation class would make a thread-safe copy of the variant value
property Value[const Name: RawUTF8]: Variant read GetValue write SetValue; default;
end;
/// allows thread-safe access to a TDocVariant document
// - this class inherits from TInterfacedObjectWithCustomCreate so you
// could define one published property of a mORMot.pas' TInjectableObject
// as ILockedDocVariant so that this class may be automatically injected
TLockedDocVariant = class(TInterfacedObjectWithCustomCreate,ILockedDocVariant)
protected
fValue: TDocVariantData;
fLock: TAutoLocker;
function GetValue(const Name: RawUTF8): Variant;
procedure SetValue(const Name: RawUTF8; const Value: Variant);
public
/// initialize the thread-safe document with a fast TDocVariant
// - i.e. call Create(true) aka Create(JSON_OPTIONS[true])
// - will be the TInterfacedObjectWithCustomCreate default constructor,
// called e.g. during IoC/DI resolution
constructor Create; overload; override;
/// initialize the thread-safe document storage
constructor Create(FastStorage: boolean); reintroduce; overload;
/// initialize the thread-safe document storage with the corresponding options
constructor Create(options: TDocVariantOptions); reintroduce; overload;
/// finalize the storage
destructor Destroy; override;
/// check and return a given property by name
function Exists(const Name: RawUTF8; out Value: Variant): boolean;
/// check and return a given property by name
// - this version
function ExistsOrLock(const Name: RawUTF8; out Value: Variant): boolean;
/// set a value by property name, and set a local copy
procedure ReplaceAndUnlock(const Name: RawUTF8; const Value: Variant; out LocalValue: Variant);
/// add an existing property value to the given TDocVariant document object
// - returns TRUE and add the Name/Value pair to Obj if Name is existing
// - returns FALSE if Name is not existing in the stored document
function AddExistingPropOrLock(const Name: RawUTF8; var Obj: variant): boolean;
/// add a property value to the given TDocVariant document object and
// to the internal stored document
procedure AddNewPropAndUnlock(const Name: RawUTF8; const Value: variant; var Obj: variant);
/// add an existing property value to the given TDocVariant document object
// - returns TRUE and add the Name/Value pair to Obj if Name is existing
// - returns FALSE if Name is not existing in the stored document
// - this method would use a lock during the Name lookup, but would always
// release the lock, even if returning FALSE (see AddExistingPropOrLock)
function AddExistingProp(const Name: RawUTF8; var Obj: variant): boolean;
/// add a property value to the given TDocVariant document object
// - this method would not expect the resource to be locked when called,
// as with AddNewPropAndUnlock
// - will use the internal lock for thread-safety
// - if the Name is already existing, would update/change the existing value
procedure AddNewProp(const Name: RawUTF8; const Value: variant; var Obj: variant);
/// append a value to the internal TDocVariant document array
procedure AddItem(const Value: variant);
/// makes a thread-safe copy of the internal TDocVariant document object or array
function Copy: variant;
/// delete all stored properties
procedure Clear;
/// save the stored value as UTF-8 encoded JSON Object
// - implemented as just a wrapper around VariantSaveJSON()
function ToJSON(HumanReadable: boolean=false): RawUTF8;
/// low-level access to the associated thread-safe mutex
function Lock: TAutoLocker;
/// the document fields would be safely accessed via this property
// - will raise an EDocVariant exception if Name does not exist
// - result variant is returned as a copy, not as varByRef, since a copy
// will definitively be more thread safe
property Value[const Name: RawUTF8]: Variant read GetValue write SetValue; default;
end;
{$endif}
{$endif}
type
/// class-reference type (metaclass) of an TSynPersistentLock class
TSynPersistentLockClass = class of TSynPersistentLock;
/// abstract dynamic array of TSynPersistentLock instance
// - note defined as T*ObjArray, since it won't
TSynPersistentLockDynArray = array of TSynPersistentLock;
/// convert a size to a human readable value power-of-two metric value
// - append EB, PB, TB, GB, MB, KB or B symbol with or without preceding space
// - for EB, PB, TB, GB, MB and KB, add one fractional digit
procedure KB(bytes: Int64; out result: TShort16; nospace: boolean); overload;
/// convert a size to a human readable value
// - append EB, PB, TB, GB, MB, KB or B symbol with preceding space
// - for EB, PB, TB, GB, MB and KB, add one fractional digit
function KB(bytes: Int64): TShort16; overload;
{$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell
/// convert a size to a human readable value
// - append EB, PB, TB, GB, MB, KB or B symbol without preceding space
// - for EB, PB, TB, GB, MB and KB, add one fractional digit
function KBNoSpace(bytes: Int64): TShort16;
{$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell
/// convert a size to a human readable value
// - append EB, PB, TB, GB, MB, KB or B symbol with or without preceding space
// - for EB, PB, TB, GB, MB and KB, add one fractional digit
function KB(bytes: Int64; nospace: boolean): TShort16; overload;
{$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell
/// convert a string size to a human readable value
// - append EB, PB, TB, GB, MB, KB or B symbol
// - for EB, PB, TB, GB, MB and KB, add one fractional digit
function KB(const buffer: RawByteString): TShort16; overload;
{$ifdef FPC_OR_UNICODE}inline;{$endif}
/// convert a size to a human readable value
// - append EB, PB, TB, GB, MB, KB or B symbol
// - for EB, PB, TB, GB, MB and KB, add one fractional digit
procedure KBU(bytes: Int64; var result: RawUTF8);
/// convert a micro seconds elapsed time into a human readable value
// - append 'us', 'ms', 's', 'm', 'h' and 'd' symbol for the given value range,
// with two fractional digits
function MicroSecToString(Micro: QWord): TShort16; overload;
{$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell
/// convert a micro seconds elapsed time into a human readable value
// - append 'us', 'ms', 's', 'm', 'h' and 'd' symbol for the given value range,
// with two fractional digits
procedure MicroSecToString(Micro: QWord; out result: TShort16); overload;
/// convert an integer value into its textual representation with thousands marked
// - ThousandSep is the character used to separate thousands in numbers with
// more than three digits to the left of the decimal separator
function IntToThousandString(Value: integer; const ThousandSep: TShort4=','): shortstring;
/// return the Delphi/FPC Compiler Version
// - returns 'Delphi 2007', 'Delphi 2010' or 'Free Pascal 3.3.1' e.g.
function GetDelphiCompilerVersion: RawUTF8;
/// returns TRUE if the supplied mutex has been initialized
// - will check if the supplied mutex is void (i.e. all filled with 0 bytes)
function IsInitializedCriticalSection(const CS: TRTLCriticalSection): Boolean;
{$ifdef HASINLINE}inline;{$endif}
/// on need initialization of a mutex, then enter the lock
// - if the supplied mutex has been initialized, do nothing
// - if the supplied mutex is void (i.e. all filled with 0), initialize it
procedure InitializeCriticalSectionIfNeededAndEnter(var CS: TRTLCriticalSection);
{$ifdef HASINLINE}inline;{$endif}
/// on need finalization of a mutex
// - if the supplied mutex has been initialized, delete it
// - if the supplied mutex is void (i.e. all filled with 0), do nothing
procedure DeleteCriticalSectionIfNeeded(var CS: TRTLCriticalSection);
/// compress a data content using the SynLZ algorithm
// - as expected by THttpSocket.RegisterCompress
// - will return 'synlz' as ACCEPT-ENCODING: header parameter
// - will store a hash of both compressed and uncompressed stream: if the
// data is corrupted during transmission, will instantly return ''
function CompressSynLZ(var DataRawByteString; Compress: boolean): AnsiString;
/// compress a data content using the SynLZ algorithm from one stream into another
// - returns the number of bytes written to Dest
// - you should specify a Magic number to be used to identify the block
function StreamSynLZ(Source: TCustomMemoryStream; Dest: TStream;
Magic: cardinal): integer; overload;
/// compress a data content using the SynLZ algorithm from one stream into a file
// - returns the number of bytes written to the destination file
// - you should specify a Magic number to be used to identify the block
function StreamSynLZ(Source: TCustomMemoryStream; const DestFile: TFileName;
Magic: cardinal): integer; overload;
/// uncompress using the SynLZ algorithm from one stream into another
// - returns a newly create memory stream containing the uncompressed data
// - returns nil if source data is invalid
// - you should specify a Magic number to be used to identify the block
// - this function will also recognize the block at the end of the source stream
// (if was appended to an existing data - e.g. a .mab at the end of a .exe)
// - on success, Source will point after all read data (so that you can e.g.
// append several data blocks to the same stream)
function StreamUnSynLZ(Source: TStream; Magic: cardinal): TMemoryStream; overload;
/// compute the real length of a given StreamSynLZ-compressed buffer
// - allows to replace an existing appended content, for instance
function StreamSynLZComputeLen(P: PAnsiChar; Len, aMagic: cardinal): integer;
/// uncompress using the SynLZ algorithm from one file into another
// - returns a newly create memory stream containing the uncompressed data
// - returns nil if source file is invalid (e.g. invalid name or invalid content)
// - you should specify a Magic number to be used to identify the block
// - this function will also recognize the block at the end of the source file
// (if was appended to an existing data - e.g. a .mab at the end of a .exe)
function StreamUnSynLZ(const Source: TFileName; Magic: cardinal): TMemoryStream; overload;
/// compress a file content using the SynLZ algorithm
// - source file is split into 128 MB blocks for fast in-memory compression of
// any file size, then SynLZ compressed and including a Hash32 checksum
// - it is not compatible with StreamSynLZ format, which has no 128 MB chunking
// - you should specify a Magic number to be used to identify the compressed
// file format
function FileSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean;
/// uncompress a file previoulsy compressed via FileSynLZ(
// - you should specify a Magic number to be used to identify the compressed
// file format
function FileUnSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean;
/// returns TRUE if the supplied file name is a SynLZ compressed file,
// matching the Magic number as supplied to FileSynLZ() function
function FileIsSynLZ(const Name: TFileName; Magic: Cardinal): boolean;
var
/// acccess to our fast SynLZ compression as a TAlgoCompress class
// - please use this global variable methods instead of the deprecated
// SynLZCompress/SynLZDecompress wrapper functions
AlgoSynLZ: TAlgoCompress;
const
/// CompressionSizeTrigger parameter SYNLZTRIG[true] will disable then
// SynLZCompress() compression
SYNLZTRIG: array[boolean] of integer = (100, maxInt);
/// used e.g. as when ALGO_SAFE[SafeDecompression] for TAlgoCompress.Decompress
ALGO_SAFE: array[boolean] of TAlgoCompressLoad = (aclNormal, aclSafeSlow);
/// deprecated function - please call AlgoSynLZ.Compress() method
function SynLZCompress(const Data: RawByteString; CompressionSizeTrigger: integer=100;
CheckMagicForCompressed: boolean=false): RawByteString; overload;
/// deprecated function - please call AlgoSynLZ.Compress() method
procedure SynLZCompress(P: PAnsiChar; PLen: integer; out Result: RawByteString;
CompressionSizeTrigger: integer=100; CheckMagicForCompressed: boolean=false); overload;
/// deprecated function - please call AlgoSynLZ.Compress() method
function SynLZCompress(P, Dest: PAnsiChar; PLen, DestLen: integer;
CompressionSizeTrigger: integer=100; CheckMagicForCompressed: boolean=false): integer; overload;
/// deprecated function - please call AlgoSynLZ.Decompress() method
function SynLZDecompress(const Data: RawByteString): RawByteString; overload;
/// deprecated function - please call AlgoSynLZ.Decompress() method
procedure SynLZDecompress(P: PAnsiChar; PLen: integer; out Result: RawByteString;
SafeDecompression: boolean=false); overload;
/// deprecated function - please call AlgoSynLZ.DecompressToBytes() method
function SynLZCompressToBytes(const Data: RawByteString;
CompressionSizeTrigger: integer=100): TByteDynArray; overload;
/// deprecated function - please call AlgoSynLZ.CompressToBytes() method
function SynLZCompressToBytes(P: PAnsiChar; PLen: integer;
CompressionSizeTrigger: integer=100): TByteDynArray; overload;
/// deprecated function - please call AlgoSynLZ.Decompress() method
function SynLZDecompress(const Data: TByteDynArray): RawByteString; overload;
/// deprecated function - please call AlgoSynLZ.Decompress() method
function SynLZDecompress(const Data: RawByteString; out Len: integer;
var tmp: RawByteString): pointer; overload;
/// deprecated function - please call AlgoSynLZ.Decompress() method
function SynLZDecompress(P: PAnsiChar; PLen: integer; out Len: integer;
var tmp: RawByteString): pointer; overload;
/// deprecated function - please call AlgoSynLZ.DecompressHeader() method
function SynLZDecompressHeader(P: PAnsiChar; PLen: integer): integer;
/// deprecated function - please call AlgoSynLZ.DecompressBody() method
function SynLZDecompressBody(P,Body: PAnsiChar; PLen,BodyLen: integer;
SafeDecompression: boolean=false): boolean;
/// deprecated function - please call AlgoSynLZ.DecompressPartial() method
function SynLZDecompressPartial(P,Partial: PAnsiChar; PLen,PartialLen: integer): integer;
implementation
{$ifdef FPC}
uses
{$ifdef FPC_X64MM}
{$ifdef CPUX64}
SynFPCx64MM,
{$else}
{$undef FPC_X64MM}
{$endif CPUX64}
{$endif FPC_X64MM}
{$ifdef LINUX}
Unix,
dynlibs,
{$ifdef BSD}
sysctl,
{$else}
Linux,
{$endif BSD}
{$ifdef FPCUSEVERSIONINFO} // to be enabled in Synopse.inc
fileinfo, // FPC 3.0 and up
{$ifdef DARWIN}
machoreader, // MACH-O executables
{$else}
elfreader, // ELF executables
{$endif DARWIN}
{$endif FPCUSEVERSIONINFO}
{$ifdef ISFPC271}
unixcp, // for GetSystemCodePage
{$endif}
SynFPCLinux,
{$endif LINUX}
SynFPCTypInfo; // small wrapper unit around FPC's TypInfo.pp
{$endif FPC}
{ ************ some fast UTF-8 / Unicode / Ansi conversion routines }
var
// internal list of TSynAnsiConvert instances
SynAnsiConvertList: TSynObjectList = nil;
{$ifdef HASINLINE}
{$ifdef USE_VTYPE_STATIC} // circumvent weird bug on BSD + ARM (Alfred)
procedure VarClear(var v: variant); // defined here for proper inlining
const VTYPE_STATIC = $BFE8; // bitmask to avoid remote VarClearProc call
var p: PInteger; // more efficient generated asm with an explicit temp variable
begin
p := @v;
if p^ and VTYPE_STATIC=0 then
p^ := 0 else
VarClearProc(PVarData(p)^);
end;
{$else}
procedure VarClear(var v: variant); // defined here for proper inlining
begin
VarClearProc(PVarData(@v)^);
end;
{$endif USE_VTYPE_STATIC}
{$endif HASINLINE}
procedure MoveSmall(Source, Dest: Pointer; Count: PtrUInt);
var c: AnsiChar; // better FPC inlining
begin
inc(PtrUInt(Source),Count);
inc(PtrUInt(Dest),Count);
PtrInt(Count) := -PtrInt(Count);
repeat
c := PAnsiChar(Source)[Count];
PAnsiChar(Dest)[Count] := c;
inc(Count);
until Count=0;
end;
{ TSynTempBuffer }
procedure TSynTempBuffer.Init(Source: pointer; SourceLen: PtrInt);
begin
len := SourceLen;
if len<=0 then
buf := nil else begin
if len<=SizeOf(tmp)-16 then
buf := @tmp else
GetMem(buf,len+16); // +16 for trailing #0 and for PInteger() parsing
if Source<>nil then begin
MoveFast(Source^,buf^,len);
PPtrInt(PAnsiChar(buf)+len)^ := 0; // init last 4/8 bytes (makes valgrid happy)
end;
end;
end;
function TSynTempBuffer.InitOnStack: pointer;
begin
buf := @tmp;
len := SizeOf(tmp);
result := @tmp;
end;
procedure TSynTempBuffer.Init(const Source: RawByteString);
begin
Init(pointer(Source),length(Source));
end;
function TSynTempBuffer.Init(Source: PUTF8Char): PUTF8Char;
begin
Init(Source,StrLen(Source));
result := buf;
end;
function TSynTempBuffer.Init(SourceLen: PtrInt): pointer;
begin
len := SourceLen;
if len<=0 then
buf := nil else begin
if len<=SizeOf(tmp)-16 then
buf := @tmp else
GetMem(buf,len+16); // +16 for trailing #0 and for PInteger() parsing
end;
result := buf;
end;
function TSynTempBuffer.Init: integer;
begin
buf := @tmp;
result := SizeOf(tmp)-16;
len := result;
end;
function TSynTempBuffer.InitRandom(RandomLen: integer; forcegsl: boolean): pointer;
begin
Init(RandomLen);
if RandomLen>0 then
FillRandom(buf,(RandomLen shr 2)+1,forcegsl);
result := buf;
end;
function TSynTempBuffer.InitIncreasing(Count, Start: PtrInt): PIntegerArray;
begin
Init((Count-Start)*4);
FillIncreasing(buf,Start,Count);
result := buf;
end;
function TSynTempBuffer.InitZero(ZeroLen: PtrInt): pointer;
begin
Init(ZeroLen-16);
FillCharFast(buf^,ZeroLen,0);
result := buf;
end;
procedure TSynTempBuffer.Done;
begin
if (buf<>@tmp) and (buf<>nil) then
FreeMem(buf);
end;
procedure TSynTempBuffer.Done(EndBuf: pointer; var Dest: RawUTF8);
begin
if EndBuf=nil then
Dest := '' else
FastSetString(Dest,buf,PAnsiChar(EndBuf)-PAnsiChar(buf));
if (buf<>@tmp) and (buf<>nil) then
FreeMem(buf);
end;
{ TSynAnsiConvert }
{$ifdef MSWINDOWS}
const
DefaultCharVar: AnsiChar = '?';
{$endif}
function TSynAnsiConvert.AnsiBufferToUnicode(Dest: PWideChar;
Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean): PWideChar;
var c: cardinal;
{$ifndef MSWINDOWS}
{$ifdef KYLIX3}
ic: iconv_t;
DestBegin: PAnsiChar;
SourceCharsBegin: integer;
{$endif}
{$endif}
begin
{$ifdef KYLIX3}
SourceCharsBegin := SourceChars;
DestBegin := pointer(Dest);
{$endif}
// first handle trailing 7 bit ASCII chars, by quad (Sha optimization)
if SourceChars>=4 then
repeat
c := PCardinal(Source)^;
if c and $80808080<>0 then
break; // break on first non ASCII quad
dec(SourceChars,4);
inc(Source,4);
PCardinal(Dest)^ := (c shl 8 or (c and $FF)) and $00ff00ff;
c := c shr 16;
PCardinal(Dest+2)^ := (c shl 8 or c) and $00ff00ff;
inc(Dest,4);
until SourceChars<4;
if (SourceChars>0) and (ord(Source^)<=127) then
repeat
dec(SourceChars);
PWord(Dest)^ := ord(Source^); // much faster than dest^ := WideChar(c) for FPC
inc(Source);
inc(Dest);
until (SourceChars=0) or (ord(Source^)>=128);
// rely on the Operating System for all remaining ASCII characters
if SourceChars=0 then
result := Dest else begin
{$ifdef MSWINDOWS}
result := Dest+MultiByteToWideChar(
fCodePage,MB_PRECOMPOSED,Source,SourceChars,Dest,SourceChars);
{$else}
{$ifdef ISDELPHIXE} // use cross-platform wrapper for MultiByteToWideChar()
result := Dest+UnicodeFromLocaleChars(
fCodePage,MB_PRECOMPOSED,Source,SourceChars,Dest,SourceChars);
{$else}
{$ifdef FPC}
// uses our SynFPCLinux ICU API helper
result := Dest+AnsiToWideICU(fCodePage,Source,Dest,SourceChars);
{$else}
{$ifdef KYLIX3}
result := Dest; // makes compiler happy
ic := LibC.iconv_open('UTF-16LE',Pointer(fIConvCodeName));
if PtrInt(ic)>=0 then
try
result := IconvBufConvert(ic,Source,SourceChars,1,
Dest,SourceCharsBegin*2-(PAnsiChar(Dest)-DestBegin),2);
finally
LibC.iconv_close(ic);
end else
{$else}
raise ESynException.CreateUTF8('%.AnsiBufferToUnicode() not supported yet for CP=%',
[self,CodePage]);
{$endif KYLIX3}
{$endif FPC}
{$endif ISDELPHIXE}
{$endif MSWINDOWS}
end;
if not NoTrailingZero then
result^ := #0;
end;
function TSynAnsiConvert.AnsiBufferToUTF8(Dest: PUTF8Char;
Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean): PUTF8Char;
var tmp: TSynTempBuffer;
c: cardinal;
U: PWideChar;
begin
// first handle trailing 7 bit ASCII chars, by quad (Sha optimization)
if SourceChars>=4 then
repeat
c := PCardinal(Source)^;
if c and $80808080<>0 then
break; // break on first non ASCII quad
PCardinal(Dest)^ := c;
dec(SourceChars,4);
inc(Source,4);
inc(Dest,4);
until SourceChars<4;
if (SourceChars>0) and (ord(Source^)<=127) then
repeat
Dest^ := Source^;
dec(SourceChars);
inc(Source);
inc(Dest);
until (SourceChars=0) or (ord(Source^)>=128);
// rely on the Operating System for all remaining ASCII characters
if SourceChars=0 then
result := Dest else begin
U := AnsiBufferToUnicode(tmp.Init(SourceChars*3),Source,SourceChars);
result := Dest+RawUnicodeToUtf8(Dest,SourceChars*3,tmp.buf,
(PtrUInt(U)-PtrUInt(tmp.buf))shr 1,[ccfNoTrailingZero]);
tmp.Done;
end;
if not NoTrailingZero then
result^ := #0;
end;
// UTF-8 is AT MOST 50% bigger than UTF-16 in bytes in range U+0800..U+FFFF
// see http://stackoverflow.com/a/7008095 -> bytes=WideCharCount*3 below
procedure TSynAnsiConvert.InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal;
DestTextWriter: TObject; Escape: TTextWriterKind);
var W: TTextWriter absolute DestTextWriter;
tmp: TSynTempBuffer;
begin // rely on explicit conversion
SourceChars := AnsiBufferToUTF8(tmp.Init(SourceChars*3),Source,SourceChars)-PUTF8Char(tmp.buf);
W.Add(tmp.buf,SourceChars,Escape);
tmp.Done;
end;
function TSynAnsiConvert.AnsiToRawUnicode(const AnsiText: RawByteString): RawUnicode;
begin
result := AnsiToRawUnicode(pointer(AnsiText),length(AnsiText));
end;
function TSynAnsiConvert.AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode;
var U: PWideChar;
tmp: TSynTempBuffer;
begin
if SourceChars=0 then
result := '' else begin
U := AnsiBufferToUnicode(tmp.Init(SourceChars*2),Source,SourceChars);
U^ := #0;
SetString(result,PAnsiChar(tmp.buf),PtrUInt(U)-PtrUInt(tmp.buf)+1);
tmp.Done;
end;
end;
function TSynAnsiConvert.AnsiToUnicodeString(Source: PAnsiChar; SourceChars: Cardinal): SynUnicode;
var tmp: TSynTempBuffer;
U: PWideChar;
begin
if SourceChars=0 then
result := '' else begin
U := AnsiBufferToUnicode(tmp.Init(SourceChars*2),Source,SourceChars);
SetString(result,PWideChar(tmp.buf),(PtrUInt(U)-PtrUInt(tmp.buf))shr 1);
tmp.Done;
end;
end;
function TSynAnsiConvert.AnsiToUnicodeString(const Source: RawByteString): SynUnicode;
var tmp: TSynTempBuffer;
U: PWideChar;
begin
if Source='' then
result := '' else begin
tmp.Init(length(Source)*2); // max dest size in bytes
U := AnsiBufferToUnicode(tmp.buf,pointer(Source),length(Source));
SetString(result,PWideChar(tmp.buf),(PtrUInt(U)-PtrUInt(tmp.buf))shr 1);
tmp.Done;
end;
end;
function TSynAnsiConvert.AnsiToUTF8(const AnsiText: RawByteString): RawUTF8;
begin
result := AnsiBufferToRawUTF8(pointer(AnsiText),length(AnsiText));
end;
function TSynAnsiConvert.AnsiBufferToRawUTF8(Source: PAnsiChar; SourceChars: Cardinal): RawUTF8;
var tmp: TSynTempBuffer;
endchar: pointer; // try circumvent Delphi 10.4 optimization issue
begin
if (Source=nil) or (SourceChars=0) then
result := '' else begin
endchar := AnsiBufferToUTF8(tmp.Init(SourceChars*3),Source,SourceChars,true);
tmp.Done(endchar,result);
end;
end;
constructor TSynAnsiConvert.Create(aCodePage: cardinal);
begin
fCodePage := aCodePage;
fAnsiCharShift := 1; // default is safe
{$ifdef KYLIX3}
fIConvCodeName := 'CP'+UInt32ToUTF8(aCodePage);
{$endif}
end;
function IsFixedWidthCodePage(aCodePage: cardinal): boolean;
begin
result := ((aCodePage>=1250) and (aCodePage<=1258)) or
(aCodePage=CODEPAGE_LATIN1) or (aCodePage=CP_RAWBYTESTRING);
end;
class function TSynAnsiConvert.Engine(aCodePage: cardinal): TSynAnsiConvert;
var i: PtrInt;
begin
if SynAnsiConvertList=nil then begin
GarbageCollectorFreeAndNil(SynAnsiConvertList,TSynObjectList.Create);
CurrentAnsiConvert := TSynAnsiConvert.Engine(GetACP);
WinAnsiConvert := TSynAnsiConvert.Engine(CODEPAGE_US) as TSynAnsiFixedWidth;
UTF8AnsiConvert := TSynAnsiConvert.Engine(CP_UTF8) as TSynAnsiUTF8;
end;
if aCodePage<=0 then begin
result := CurrentAnsiConvert;
exit;
end;
with SynAnsiConvertList do
for i := 0 to Count-1 do begin
result := List[i];
if result.CodePage=aCodePage then
exit;
end;
if aCodePage=CP_UTF8 then
result := TSynAnsiUTF8.Create(CP_UTF8) else
if aCodePage=CP_UTF16 then
result := TSynAnsiUTF16.Create(CP_UTF16) else
if IsFixedWidthCodePage(aCodePage) then
result := TSynAnsiFixedWidth.Create(aCodePage) else
result := TSynAnsiConvert.Create(aCodePage);
SynAnsiConvertList.Add(result);
end;
function TSynAnsiConvert.UnicodeBufferToAnsi(Dest: PAnsiChar;
Source: PWideChar; SourceChars: Cardinal): PAnsiChar;
var c: cardinal;
{$ifndef MSWINDOWS}
{$ifdef KYLIX3}
ic: iconv_t;
DestBegin: PAnsiChar;
SourceCharsBegin: integer;
{$endif}
{$endif MSWINDOWS}
begin
{$ifdef KYLIX3}
SourceCharsBegin := SourceChars;
DestBegin := Dest;
{$endif}
// first handle trailing 7 bit ASCII chars, by pairs (Sha optimization)
if SourceChars>=2 then
repeat
c := PCardinal(Source)^;
if c and $ff80ff80<>0 then
break; // break on first non ASCII pair
dec(SourceChars,2);
inc(Source,2);
c := c shr 8 or c;
PWord(Dest)^ := c;
inc(Dest,2);
until SourceChars<2;
if (SourceChars>0) and (ord(Source^)<=127) then
repeat
Dest^ := AnsiChar(ord(Source^));
dec(SourceChars);
inc(Source);
inc(Dest);
until (SourceChars=0) or (ord(Source^)>=128);
// rely on the Operating System for all remaining ASCII characters
if SourceChars=0 then
result := Dest else begin
{$ifdef MSWINDOWS}
result := Dest+WideCharToMultiByte(
fCodePage,0,Source,SourceChars,Dest,SourceChars*3,@DefaultCharVar,nil);
{$else}
{$ifdef ISDELPHIXE} // use cross-platform wrapper for WideCharToMultiByte()
result := Dest+System.LocaleCharsFromUnicode(
fCodePage,0,Source,SourceChars,Dest,SourceChars*3,@DefaultCharVar,nil);
{$else}
{$ifdef FPC}
// uses our SynFPCLinux ICU API helper
result := Dest+WideToAnsiICU(fCodePage,Source,Dest,SourceChars);
{$else}
{$ifdef KYLIX3}
result := Dest; // makes compiler happy
ic := LibC.iconv_open(Pointer(fIConvCodeName),'UTF-16LE');
if PtrInt(ic)>=0 then
try
result := IconvBufConvert(ic,Source,SourceChars,2,
Dest,SourceCharsBegin*3-(PAnsiChar(Dest)-DestBegin),1);
finally
LibC.iconv_close(ic);
end else
{$else}
raise ESynException.CreateUTF8('%.UnicodeBufferToAnsi() not supported yet for CP=%',
[self,CodePage]); {$endif KYLIX3}
{$endif FPC}
{$endif ISDELPHIXE}
{$endif MSWINDOWS}
end;
end;
function TSynAnsiConvert.UTF8BufferToAnsi(Dest: PAnsiChar;
Source: PUTF8Char; SourceChars: Cardinal): PAnsiChar;
var tmp: TSynTempBuffer;
begin
if (Source=nil) or (SourceChars=0) then
result := Dest else begin
tmp.Init((SourceChars+1) shl fAnsiCharShift);
result := UnicodeBufferToAnsi(Dest,tmp.buf,UTF8ToWideChar(tmp.buf,Source,SourceChars) shr 1);
tmp.Done;
end;
end;
function TSynAnsiConvert.UTF8BufferToAnsi(Source: PUTF8Char;
SourceChars: Cardinal): RawByteString;
begin
UTF8BufferToAnsi(Source,SourceChars,result);
end;
procedure TSynAnsiConvert.UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal;
var result: RawByteString);
var tmp: TSynTempBuffer;
begin
if (Source=nil) or (SourceChars=0) then
result := '' else begin
tmp.Init((SourceChars+1) shl fAnsiCharShift);
FastSetStringCP(result,tmp.buf,
Utf8BufferToAnsi(tmp.buf,Source,SourceChars)-PAnsiChar(tmp.buf),fCodePage);
tmp.Done;
end;
end;
function TSynAnsiConvert.UTF8ToAnsi(const UTF8: RawUTF8): RawByteString;
begin
UTF8BufferToAnsi(pointer(UTF8),length(UTF8),result);
end;
function TSynAnsiConvert.Utf8ToAnsiBuffer(const S: RawUTF8;
Dest: PAnsiChar; DestSize: integer): integer;
var tmp: array[0..2047] of AnsiChar; // truncated to 2KB as documented
begin
if (DestSize<=0) or (Dest=nil) then begin
result := 0;
exit;
end;
result := length(s);
if result>0 then begin
if result>SizeOf(tmp) then
result := SizeOf(tmp);
result := UTF8BufferToAnsi(tmp,pointer(s),result)-tmp;
if result>=DestSize then
result := DestSize-1;
MoveFast(tmp,Dest^,result);
end;
Dest[result] := #0;
end;
function TSynAnsiConvert.UnicodeBufferToAnsi(Source: PWideChar; SourceChars: Cardinal): RawByteString;
var tmp: TSynTempBuffer;
begin
if (Source=nil) or (SourceChars=0) then
result := '' else begin
tmp.Init((SourceChars+1) shl fAnsiCharShift);
FastSetStringCP(result,tmp.buf,
UnicodeBufferToAnsi(tmp.buf,Source,SourceChars)-PAnsiChar(tmp.buf),fCodePage);
tmp.Done;
end;
end;
function TSynAnsiConvert.RawUnicodeToAnsi(const Source: RawUnicode): RawByteString;
begin
result := UnicodeBufferToAnsi(pointer(Source),length(Source) shr 1);
end;
function TSynAnsiConvert.AnsiToAnsi(From: TSynAnsiConvert; const Source: RawByteString): RawByteString;
begin
if From=self then
result := Source else
result := AnsiToAnsi(From,pointer(Source),length(Source));
end;
function TSynAnsiConvert.AnsiToAnsi(From: TSynAnsiConvert; Source: PAnsiChar; SourceChars: cardinal): RawByteString;
var tmpU: array[byte] of WideChar;
U: PWideChar;
begin
if From=self then
FastSetStringCP(result,Source,SourceChars,fCodePage) else
if (Source=nil) or (SourceChars=0) then
result := '' else
if 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;
end;
{ TSynAnsiFixedWidth }
function TSynAnsiFixedWidth.AnsiBufferToUnicode(Dest: PWideChar;
Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean): PWideChar;
var i: Integer;
tab: PWordArray;
begin
// PWord*(Dest)[] is much faster than dest^ := WideChar(c) for FPC
tab := pointer(fAnsiToWide);
for i := 1 to SourceChars shr 2 do begin
PWordArray(Dest)[0] := tab[Ord(Source[0])];
PWordArray(Dest)[1] := tab[Ord(Source[1])];
PWordArray(Dest)[2] := tab[Ord(Source[2])];
PWordArray(Dest)[3] := tab[Ord(Source[3])];
inc(Source,4);
inc(Dest,4);
end;
for i := 1 to SourceChars and 3 do begin
PWord(Dest)^ := tab[Ord(Source^)];
inc(Dest);
inc(Source);
end;
if not NoTrailingZero then
Dest^ := #0;
result := Dest;
end;
{$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; NoTrailingZero: boolean): PUTF8Char;
var EndSource, EndSourceBy4: PAnsiChar;
c: Cardinal;
label By4, By1; // ugly but faster
begin
if (self=nil) or (Dest=nil) then begin
Result := nil;
Exit;
end else
if (Source<>nil) and (SourceChars>0) then begin
// handle 7 bit ASCII WideChars, by quads (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;
if not NoTrailingZero then
Dest^ := #0;
{$ifdef ISDELPHI104}
exit(Dest); // circumvent Delphi 10.4 optimizer bug
{$else}
Result := Dest;
{$endif}
end;
procedure TSynAnsiFixedWidth.InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal;
DestTextWriter: TObject; Escape: TTextWriterKind);
begin
TTextWriter(DestTextWriter).InternalAddFixedAnsi(
Source,SourceChars,pointer(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: PtrInt;
A256: array[0..256] of AnsiChar;
U256: array[0..256] of WideChar; // AnsiBufferToUnicode() write a last #0
begin
inherited;
if not IsFixedWidthCodePage(aCodePage) then
// ESynException.CreateUTF8() uses UTF8ToString() -> use CreateFmt() here
raise ESynException.CreateFmt('%s.Create - Invalid code page %d',
[ClassName,fCodePage]);
// create internal look-up tables
SetLength(fAnsiToWide,256);
if (aCodePage=CODEPAGE_US) or (aCodePage=CODEPAGE_LATIN1) or
(aCodePage=CP_RAWBYTESTRING) then begin
for i := 0 to 255 do
fAnsiToWide[i] := i;
if aCodePage=CODEPAGE_US then // do not trust the Windows API :(
for i := low(WinAnsiUnicodeChars) to high(WinAnsiUnicodeChars) do
fAnsiToWide[i] := WinAnsiUnicodeChars[i];
end else begin // from Operating System returned values
for i := 0 to 255 do
A256[i] := AnsiChar(i);
FillcharFast(U256,SizeOf(U256),0);
if PtrUInt(inherited AnsiBufferToUnicode(U256,A256,256))-PtrUInt(@U256)>512 then
// warning: CreateUTF8() uses UTF8ToString() -> use CreateFmt() now
raise ESynException.CreateFmt('OS error for %s.Create(%d)',[ClassName,aCodePage]);
MoveFast(U256[0],fAnsiToWide[0],512);
end;
SetLength(fWideToAnsi,65536);
for i := 1 to 126 do
fWideToAnsi[i] := i;
FillcharFast(fWideToAnsi[127],65536-127,ord('?')); // '?' for unknown char
for i := 127 to 255 do
if (fAnsiToWide[i]<>0) and (fAnsiToWide[i]<>ord('?')) then
fWideToAnsi[fAnsiToWide[i]] := i;
// fixed width Ansi will never be bigger than UTF-8
fAnsiCharShift := 0;
end;
function TSynAnsiFixedWidth.IsValidAnsi(WideText: PWideChar; Length: PtrInt): boolean;
var i: PtrInt;
wc: PtrUInt;
begin
result := false;
if WideText<>nil then
for i := 0 to Length-1 do begin
wc := PtrUInt(WideText[i]);
if wc=0 then
break else
if wc<256 then
if fAnsiToWide[wc]<256 then
continue else
exit else
if fWideToAnsi[wc]=ord('?') then
exit else
continue;
end;
result := true;
end;
function TSynAnsiFixedWidth.IsValidAnsi(WideText: PWideChar): boolean;
var wc: PtrUInt;
begin
result := false;
if WideText<>nil then
repeat
wc := PtrUInt(WideText^);
inc(WideText);
if wc=0 then
break else
if wc<256 then
if fAnsiToWide[wc]<256 then
continue else
exit else
if fWideToAnsi[wc]=ord('?') then
exit else
continue;
until false;
result := true;
end;
function TSynAnsiFixedWidth.IsValidAnsiU(UTF8Text: PUTF8Char): boolean;
var c: PtrUInt;
i, extra: PtrInt;
begin
result := false;
if UTF8Text<>nil then
repeat
c := byte(UTF8Text^);
inc(UTF8Text);
if c=0 then break else
if c<=127 then
continue else begin
extra := UTF8_EXTRABYTES[c];
if UTF8_EXTRA[extra].minimum>$ffff then
exit;
for i := 1 to extra do begin
if byte(UTF8Text^) and $c0<>$80 then exit; // invalid UTF-8 content
c := c shl 6+byte(UTF8Text^);
inc(UTF8Text);
end;
dec(c,UTF8_EXTRA[extra].offset);
if (c>$ffff) or (fWideToAnsi[c]=ord('?')) then
exit; // invalid char in the WinAnsi code page
end;
until false;
result := true;
end;
function TSynAnsiFixedWidth.IsValidAnsiU8Bit(UTF8Text: PUTF8Char): boolean;
var c: PtrUInt;
i, extra: PtrInt;
begin
result := false;
if UTF8Text<>nil then
repeat
c := byte(UTF8Text^);
inc(UTF8Text);
if c=0 then break else
if c<=127 then
continue else begin
extra := UTF8_EXTRABYTES[c];
if UTF8_EXTRA[extra].minimum>$ffff then
exit;
for i := 1 to extra do begin
if byte(UTF8Text^) and $c0<>$80 then exit; // invalid UTF-8 content
c := c shl 6+byte(UTF8Text^);
inc(UTF8Text);
end;
dec(c,UTF8_EXTRA[extra].offset);
if (c>255) or (fAnsiToWide[c]>255) then
exit; // not 8 bit char (like "tm" or such) is marked invalid
end;
until false;
result := true;
end;
function TSynAnsiFixedWidth.UnicodeBufferToAnsi(Dest: PAnsiChar;
Source: PWideChar; SourceChars: Cardinal): PAnsiChar;
var c: cardinal;
tab: PAnsiChar;
begin
// first handle trailing 7 bit ASCII chars, by pairs (Sha optimization)
if SourceChars>=2 then
repeat
c := PCardinal(Source)^;
if c and $ff80ff80<>0 then
break; // break on first non ASCII pair
dec(SourceChars,2);
inc(Source,2);
c := c shr 8 or c;
PWord(Dest)^ := c;
inc(Dest,2);
until SourceChars<2;
// use internal lookup tables for fast process of remaining chars
tab := pointer(fWideToAnsi);
for c := 1 to SourceChars shr 2 do begin
Dest[0] := tab[Ord(Source[0])];
Dest[1] := tab[Ord(Source[1])];
Dest[2] := tab[Ord(Source[2])];
Dest[3] := tab[Ord(Source[3])];
inc(Source,4);
inc(Dest,4);
end;
for c := 1 to SourceChars and 3 do begin
Dest^ := tab[Ord(Source^)];
inc(Dest);
inc(Source);
end;
result := Dest;
end;
function TSynAnsiFixedWidth.UTF8BufferToAnsi(Dest: PAnsiChar;
Source: PUTF8Char; SourceChars: Cardinal): PAnsiChar;
var c: cardinal;
endSource, endSourceBy4: PUTF8Char;
i,extra: integer;
label By1, By4, Quit; // ugly but faster
begin
// first handle trailing 7 bit ASCII chars, by quad (Sha optimization)
endSource := Source+SourceChars;
endSourceBy4 := endSource-4;
if (PtrUInt(Source) and 3=0) and (Source<=endSourceBy4) then
repeat
By4: c := PCardinal(Source)^;
if c and $80808080<>0 then
goto By1; // break on first non ASCII quad
PCardinal(Dest)^ := c;
inc(Source,4);
inc(Dest,4);
until Source>endSourceBy4;
// generic loop, handling one UTF-8 code per iteration
if Source<endSource then
repeat
By1: c := byte(Source^);
inc(Source);
if ord(c)<=127 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; NoTrailingZero: boolean): PWideChar;
begin
result := Dest+
(UTF8ToWideChar(Dest,PUTF8Char(Source),SourceChars,NoTrailingZero) shr 1);
end;
function TSynAnsiUTF8.AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar;
SourceChars: Cardinal; NoTrailingZero: boolean): PUTF8Char;
begin
MoveFast(Source^,Dest^,SourceChars);
if not NoTrailingZero then
Dest[SourceChars] := #0;
result := Dest+SourceChars;
end;
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.UnicodeBufferToUTF8(Dest: PAnsiChar; DestChars: Cardinal;
Source: PWideChar; SourceChars: Cardinal): PAnsiChar;
begin
result := Dest+RawUnicodeToUTF8(PUTF8Char(Dest),DestChars,Source,SourceChars,
[ccfNoTrailingZero]);
end;
function TSynAnsiUTF8.UnicodeBufferToAnsi(Dest: PAnsiChar;
Source: PWideChar; SourceChars: Cardinal): PAnsiChar;
begin
result := UnicodeBufferToUTF8(Dest,SourceChars,Source,SourceChars);
end;
function TSynAnsiUTF8.UnicodeBufferToAnsi(Source: PWideChar;
SourceChars: Cardinal): RawByteString;
var tmp: TSynTempBuffer;
begin
if (Source=nil) or (SourceChars=0) then
result := '' else begin
tmp.Init(SourceChars*3);
FastSetStringCP(result,tmp.buf,UnicodeBufferToUTF8(tmp.buf,
SourceChars*3,Source,SourceChars)-PAnsiChar(tmp.buf),fCodePage);
tmp.Done;
end;
end;
function TSynAnsiUTF8.UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char;
SourceChars: Cardinal): PAnsiChar;
begin
MoveFast(Source^,Dest^,SourceChars);
result := Dest+SourceChars;
end;
procedure TSynAnsiUTF8.UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal;
var result: RawByteString);
begin
FastSetString(RawUTF8(result),Source,SourceChars);
end;
function TSynAnsiUTF8.UTF8ToAnsi(const UTF8: RawUTF8): RawByteString;
begin
result := UTF8;
{$ifdef HASCODEPAGE}
SetCodePage(result,CP_UTF8,false);
{$endif}
end;
function TSynAnsiUTF8.AnsiToUTF8(const AnsiText: RawByteString): RawUTF8;
begin
result := AnsiText;
{$ifdef HASCODEPAGE}
SetCodePage(RawByteString(result),CP_UTF8,false);
{$endif}
end;
function TSynAnsiUTF8.AnsiBufferToRawUTF8(Source: PAnsiChar; SourceChars: Cardinal): RawUTF8;
begin
FastSetString(Result,Source,SourceChars);
end;
{ TSynAnsiUTF16 }
function TSynAnsiUTF16.AnsiBufferToUnicode(Dest: PWideChar;
Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean): PWideChar;
begin
MoveFast(Source^,Dest^,SourceChars);
result := Pointer(PtrUInt(Dest)+SourceChars);
if not NoTrailingZero then
result^ := #0;
end;
const
NOTRAILING: array[boolean] of TCharConversionFlags =
([],[ccfNoTrailingZero]);
function TSynAnsiUTF16.AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar;
SourceChars: Cardinal; NoTrailingZero: boolean): PUTF8Char;
begin
SourceChars := SourceChars shr 1; // from byte count to WideChar count
result := Dest+RawUnicodeToUtf8(Dest,SourceChars*3,
PWideChar(Source),SourceChars,NOTRAILING[NoTrailingZero]);
end;
function TSynAnsiUTF16.AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode;
begin
SetString(result,Source,SourceChars); // byte count
end;
constructor TSynAnsiUTF16.Create(aCodePage: cardinal);
begin
if aCodePage<>CP_UTF16 then
raise ESynException.CreateUTF8('%.Create(%)',[self,aCodePage]);
inherited Create(aCodePage);
end;
function TSynAnsiUTF16.UnicodeBufferToAnsi(Dest: PAnsiChar;
Source: PWideChar; SourceChars: Cardinal): PAnsiChar;
begin
SourceChars := SourceChars shl 1; // from WideChar count to byte count
MoveFast(Source^,Dest^,SourceChars);
result := Dest+SourceChars;
end;
function TSynAnsiUTF16.UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char;
SourceChars: Cardinal): PAnsiChar;
begin
result := Dest+UTF8ToWideChar(PWideChar(Dest),Source,SourceChars,true);
end;
function WideCharToUtf8(Dest: PUTF8Char; aWideChar: PtrUInt): integer;
begin
if aWideChar<=$7F then begin
Dest^ := AnsiChar(aWideChar);
result := 1;
end else
if aWideChar>$7ff then begin
Dest[0] := AnsiChar($E0 or (aWideChar shr 12));
Dest[1] := AnsiChar($80 or ((aWideChar shr 6) and $3F));
Dest[2] := AnsiChar($80 or (aWideChar and $3F));
result := 3;
end else begin
Dest[0] := AnsiChar($C0 or (aWideChar shr 6));
Dest[1] := AnsiChar($80 or (aWideChar and $3F));
result := 2;
end;
end;
function UTF16CharToUtf8(Dest: PUTF8Char; var Source: PWord): integer;
var c: cardinal;
j: integer;
begin
c := Source^;
inc(Source);
case c of
0..$7f: begin
Dest^ := AnsiChar(c);
result := 1;
exit;
end;
UTF16_HISURROGATE_MIN..UTF16_HISURROGATE_MAX: begin
c := ((c-$D7C0)shl 10)+(Source^ xor UTF16_LOSURROGATE_MIN);
inc(Source);
end;
UTF16_LOSURROGATE_MIN..UTF16_LOSURROGATE_MAX: begin
c := ((cardinal(Source^)-$D7C0)shl 10)+(c xor UTF16_LOSURROGATE_MIN);
inc(Source);
end;
end; // now c is the UTF-32/UCS4 code point
case c of
0..$7ff: result := 2;
$800..$ffff: result := 3;
$10000..$1FFFFF: result := 4;
$200000..$3FFFFFF: result := 5;
else result := 6;
end;
for j := result-1 downto 1 do begin
Dest[j] := AnsiChar((c and $3f)+$80);
c := c shr 6;
end;
Dest^ := AnsiChar(Byte(c) or UTF8_FIRSTBYTE[result]);
end;
function UCS4ToUTF8(ucs4: cardinal; Dest: PUTF8Char): integer;
var j: integer;
begin
case ucs4 of
0..$7f: begin
Dest^ := AnsiChar(ucs4);
result := 1;
exit;
end;
$80..$7ff: result := 2;
$800..$ffff: result := 3;
$10000..$1FFFFF: result := 4;
$200000..$3FFFFFF: result := 5;
else result := 6;
end;
for j := result-1 downto 1 do begin
Dest[j] := AnsiChar((ucs4 and $3f)+$80);
ucs4 := ucs4 shr 6;
end;
Dest^ := AnsiChar(Byte(ucs4) or UTF8_FIRSTBYTE[result]);
end;
procedure AnyAnsiToUTF8(const s: RawByteString; var result: RawUTF8);
{$ifdef HASCODEPAGE}var CodePage: Cardinal;{$endif}
begin
if s='' then
result := '' else begin
{$ifdef HASCODEPAGE}
CodePage := StringCodePage(s);
if (CodePage=CP_UTF8) or (CodePage=CP_RAWBYTESTRING) then
result := s else
result := TSynAnsiConvert.Engine(CodePage).
{$else}
result := CurrentAnsiConvert.
{$endif}
AnsiBufferToRawUTF8(pointer(s),length(s));
end;
end;
function AnyAnsiToUTF8(const s: RawByteString): RawUTF8;
begin
AnyAnsiToUTF8(s,result);
end;
function WinAnsiBufferToUtf8(Dest: PUTF8Char; Source: PAnsiChar; SourceChars: Cardinal): PUTF8Char;
begin
result := WinAnsiConvert.AnsiBufferToUTF8(Dest,Source,SourceChars);
end;
function ShortStringToUTF8(const source: ShortString): RawUTF8;
begin
result := WinAnsiConvert.AnsiBufferToRawUTF8(@source[1],ord(source[0]));
end;
procedure WinAnsiToUnicodeBuffer(const S: WinAnsiString; Dest: PWordArray; DestLen: PtrInt);
var L: PtrInt;
begin
L := length(S);
if L<>0 then begin
if L>=DestLen then
L := DestLen-1; // truncate to avoid buffer overflow
WinAnsiConvert.AnsiBufferToUnicode(PWideChar(Dest),pointer(S),L); // include last #0
end else
Dest^[0] := 0;
end;
function WinAnsiToRawUnicode(const S: WinAnsiString): RawUnicode;
begin
result := WinAnsiConvert.AnsiToRawUnicode(S);
end;
function WinAnsiToUtf8(const S: WinAnsiString): RawUTF8;
begin
result := WinAnsiConvert.AnsiBufferToRawUTF8(pointer(S),length(s));
end;
function WinAnsiToUtf8(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): RawUTF8;
begin
result := WinAnsiConvert.AnsiBufferToRawUTF8(WinAnsi,WinAnsiLen);
end;
function WideCharToWinAnsiChar(wc: cardinal): AnsiChar;
begin
wc := WinAnsiConvert.WideCharToAnsiChar(wc);
if integer(wc)=-1 then
result := '?' else
result := AnsiChar(wc);
end;
function WideCharToWinAnsi(wc: cardinal): integer;
begin
result := WinAnsiConvert.WideCharToAnsiChar(wc);
end;
function IsWinAnsi(WideText: PWideChar; Length: integer): boolean;
begin
result := WinAnsiConvert.IsValidAnsi(WideText,Length);
end;
function IsAnsiCompatible(PC: PAnsiChar): boolean;
begin
result := false;
if PC<>nil then
while true do
if PC^=#0 then
break else
if PC^<=#127 then
inc(PC) else // 7 bits chars are always OK, whatever codepage/charset is used
exit;
result := true;
end;
function IsAnsiCompatible(PC: PAnsiChar; Len: PtrUInt): boolean;
begin
if PC<>nil then begin
result := false;
Len := PtrUInt(@PC[Len-4]);
if Len>=PtrUInt(PC) then
repeat
if PCardinal(PC)^ and $80808080<>0 then
exit;
inc(PC,4);
until Len<PtrUInt(PC);
inc(Len,4);
if Len>PtrUInt(PC) then
repeat
if PC^>=#127 then
exit;
inc(PC);
until Len<=PtrUInt(PC);
end;
result := true;
end;
function IsAnsiCompatible(const Text: RawByteString): boolean;
begin
result := IsAnsiCompatible(PAnsiChar(pointer(Text)),length(Text));
end;
function IsAnsiCompatibleW(PW: PWideChar): boolean;
begin
result := false;
if PW<>nil then
while true do
if ord(PW^)=0 then
break else
if ord(PW^)<=127 then
inc(PW) else // 7 bits chars are always OK, whatever codepage/charset is used
exit;
result := true;
end;
function IsAnsiCompatibleW(PW: PWideChar; Len: PtrInt): boolean;
var i: PtrInt;
begin
result := false;
if PW<>nil then
for i := 0 to Len-1 do
if ord(PW[i])>127 then
exit;
result := true;
end;
function IsWinAnsi(WideText: PWideChar): boolean;
begin
result := WinAnsiConvert.IsValidAnsi(WideText);
end;
function IsWinAnsiU(UTF8Text: PUTF8Char): boolean;
begin
result := WinAnsiConvert.IsValidAnsiU(UTF8Text);
end;
function IsWinAnsiU8Bit(UTF8Text: PUTF8Char): boolean;
begin
result := WinAnsiConvert.IsValidAnsiU8Bit(UTF8Text);
end;
function UTF8ToWinPChar(dest: PAnsiChar; source: PUTF8Char; count: integer): integer;
begin
result := WinAnsiConvert.UTF8BufferToAnsi(dest,source,count)-dest;
end;
function ShortStringToAnsi7String(const source: shortstring): RawByteString;
begin
FastSetString(RawUTF8(result),@source[1],ord(source[0]));
end;
procedure ShortStringToAnsi7String(const source: shortstring; var result: RawUTF8);
begin
FastSetString(result,@source[1],ord(source[0]));
end;
procedure UTF8ToShortString(var dest: shortstring; source: PUTF8Char);
var c: cardinal;
len,extra,i: integer;
begin
len := 0;
if source<>nil then
repeat
c := byte(source^); inc(source);
if c=0 then break else
if c<=127 then begin
inc(len); dest[len] := AnsiChar(c);
if len<253 then continue else break;
end else begin
extra := UTF8_EXTRABYTES[c];
if extra=0 then break; // invalid leading byte
for i := 1 to extra do begin
if byte(source^) and $c0<>$80 then begin
dest[0] := AnsiChar(len);
exit; // invalid UTF-8 content
end;
c := c shl 6+byte(source^);
inc(Source);
end;
dec(c,UTF8_EXTRA[extra].offset);
// #256.. -> slower but accurate conversion
inc(len);
if c>$ffff then
dest[len] := '?' else
dest[len] := AnsiChar(WinAnsiConvert.fWideToAnsi[c]);
if len<253 then continue else break;
end;
until false;
dest[0] := AnsiChar(len);
end;
function Utf8ToWinAnsi(const S: RawUTF8): WinAnsiString;
begin
result := WinAnsiConvert.UTF8ToAnsi(S);
end;
function Utf8ToWinAnsi(P: PUTF8Char): WinAnsiString;
begin
result := WinAnsiConvert.UTF8ToAnsi(P);
end;
procedure Utf8ToRawUTF8(P: PUTF8Char; var result: RawUTF8);
begin // fast and Delphi 2009+ ready
FastSetString(result,P,StrLen(P));
end;
function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char;
MaxDestChars, sourceBytes: PtrInt; NoTrailingZero: boolean): PtrInt;
// faster than System.Utf8ToUnicode()
var c: cardinal;
begd: PWideChar;
endSource: PUTF8Char;
endDest: PWideChar;
i,extra: integer;
label Quit, NoSource;
begin
result := 0;
if dest=nil then
exit;
if source=nil then
goto NoSource;
if sourceBytes=0 then begin
if source^=#0 then
goto NoSource;
sourceBytes := StrLen(source);
end;
endSource := source+sourceBytes;
endDest := dest+MaxDestChars;
begd := dest;
repeat
c := byte(source^);
inc(source);
if c<=127 then begin
PWord(dest)^ := c; // much faster than dest^ := WideChar(c) for FPC
inc(dest);
if (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:
if not NoTrailingZero then
dest^ := #0; // always append a WideChar(0) to the end of the buffer
end;
function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; sourceBytes: PtrInt;
NoTrailingZero: boolean): PtrInt;
// faster than System.UTF8Decode()
var c: cardinal;
begd: PWideChar;
endSource, endSourceBy4: PUTF8Char;
i,extra: PtrInt;
label Quit, NoSource, By1, By4;
begin
result := 0;
if dest=nil then
exit;
if source=nil then
goto NoSource;
if sourceBytes=0 then begin
if source^=#0 then
goto NoSource;
sourceBytes := StrLen(source);
end;
begd := dest;
endSource := Source+SourceBytes;
endSourceBy4 := endSource-4;
if (PtrUInt(Source) and 3=0) and (Source<=EndSourceBy4) then
repeat // handle 7 bit ASCII chars, by quad (Sha optimization)
By4: c := PCardinal(Source)^;
if c and $80808080<>0 then
goto By1; // break on first non ASCII quad
inc(Source,4);
PCardinal(dest)^ := (c shl 8 or (c and $FF)) and $00ff00ff;
c := c shr 16;
PCardinal(dest+2)^ := (c shl 8 or c) and $00ff00ff;
inc(dest,4);
until Source>EndSourceBy4;
if Source<endSource then
repeat
By1: c := byte(Source^); inc(Source);
if c<=127 then begin
PWord(dest)^ := c; // much faster than dest^ := WideChar(c) for FPC
inc(dest);
if (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 returns bytes length
NoSource:
if not NoTrailingZero then
dest^ := #0; // always append a WideChar(0) to the end of the buffer
end;
function IsValidUTF8WithoutControlChars(source: PUTF8Char): Boolean;
var extra, i: integer;
c: cardinal;
begin
result := false;
if source<>nil then
repeat
c := byte(source^);
inc(source);
if c=0 then break else
if c<32 then exit else // disallow #1..#31 control char
if c and $80<>0 then begin
extra := UTF8_EXTRABYTES[c];
if extra=0 then exit else // invalid leading byte
for i := 1 to extra do
if byte(source^) and $c0<>$80 then // invalid UTF-8 encoding
exit else
inc(source);
end;
until false;
result := true;
end;
function IsValidUTF8WithoutControlChars(const source: RawUTF8): Boolean;
var s, extra, i, len: integer;
c: cardinal;
begin
result := false;
s := 1;
len := length(source);
while s<=len do begin
c := byte(source[s]);
inc(s);
if c<32 then exit else // disallow #0..#31 control char
if c and $80<>0 then begin
extra := UTF8_EXTRABYTES[c];
if extra=0 then exit else // invalid leading byte
for i := 1 to extra do
if byte(source[s]) and $c0<>$80 then // reached #0 or invalid UTF-8
exit else
inc(s);
end;
end;
result := true;
end;
function Utf8ToUnicodeLength(source: PUTF8Char): PtrUInt;
var c: PtrUInt;
extra,i: integer;
begin
result := 0;
if source<>nil then
repeat
c := byte(source^);
inc(source);
if c=0 then break else
if c<=127 then
inc(result) else begin
extra := UTF8_EXTRABYTES[c];
if extra=0 then exit else // invalid leading byte
if extra>=UTF8_EXTRA_SURROGATE then
inc(result,2) else
inc(result);
for i := 1 to extra do // inc(source,extra) is faster but not safe
if byte(source^) and $c0<>$80 then
exit else
inc(source); // check valid UTF-8 content
end;
until false;
end;
function Utf8TruncateToUnicodeLength(var text: RawUTF8; maxUTF16: integer): boolean;
var c: PtrUInt;
extra,i: integer;
source: PUTF8Char;
begin
source := pointer(text);
if (source<>nil) and (cardinal(maxUtf16)<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<=127 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; maxBytes: PtrUInt): boolean;
begin
if PtrUInt(length(text))<maxBytes then begin
result := false;
exit; // nothing to truncate
end;
while (maxBytes>0) and (ord(text[maxBytes]) and $c0=$80) do dec(maxBytes);
if (maxBytes>0) and (ord(text[maxBytes]) and $80<>0) then dec(maxBytes);
SetLength(text,maxBytes);
result := true;
end;
function Utf8TruncatedLength(const text: RawUTF8; maxBytes: PtrUInt): PtrInt;
begin
result := length(text);
if PtrUInt(result)<maxBytes then
exit;
result := maxBytes;
while (result>0) and (ord(text[result]) and $c0=$80) do dec(result);
if (result>0) and (ord(text[result]) and $80<>0) then dec(result);
end;
function Utf8TruncatedLength(text: PAnsiChar; textlen,maxBytes: PtrUInt): PtrInt;
begin
if textlen<maxBytes then begin
result := textlen;
exit;
end;
result := maxBytes;
while (result>0) and (ord(text[result]) and $c0=$80) do dec(result);
if (result>0) and (ord(text[result]) and $80<>0) then dec(result);
end;
function Utf8FirstLineToUnicodeLength(source: PUTF8Char): PtrInt;
var c,extra: PtrUInt;
begin
result := 0;
if source<>nil then
repeat
c := byte(source^);
inc(source);
if c in [0,10,13] then break else // #0, #10 or #13 stop the count
if c<=127 then
inc(result) else begin
extra := UTF8_EXTRABYTES[c];
if extra=0 then exit else // invalid leading byte
if extra>=UTF8_EXTRA_SURROGATE then
inc(result,2) else
inc(result);
inc(source,extra); // a bit less safe, but faster
end;
until false;
end;
function Utf8DecodeToRawUnicode(P: PUTF8Char; L: integer): RawUnicode;
var tmp: TSynTempBuffer;
begin
result := ''; // somewhat faster if result is freed before any SetLength()
if L=0 then
L := StrLen(P);
if L=0 then
exit;
// +1 below is for #0 ending -> true WideChar(#0) ending
tmp.Init(L*3); // maximum posible unicode size (if all <#128)
SetString(result,PAnsiChar(tmp.buf),UTF8ToWideChar(tmp.buf,P,L)+1);
tmp.Done;
end;
function Utf8DecodeToRawUnicode(const S: RawUTF8): RawUnicode;
begin
if S='' then
result := '' else
result := Utf8DecodeToRawUnicode(pointer(S),length(S));
end;
function Utf8DecodeToRawUnicodeUI(const S: RawUTF8; DestLen: PInteger): RawUnicode;
var L: integer;
begin
L := Utf8DecodeToRawUnicodeUI(S,result);
if DestLen<>nil then
DestLen^ := L;
end;
function Utf8DecodeToRawUnicodeUI(const S: RawUTF8; var Dest: RawUnicode): integer;
begin
Dest := ''; // somewhat faster if Dest is freed before any SetLength()
if S='' then begin
result := 0;
exit;
end;
result := length(S);
SetLength(Dest,result*2+2);
result := UTF8ToWideChar(pointer(Dest),Pointer(S),result);
end;
function RawUnicodeToUtf8(Dest: PUTF8Char; DestLen: PtrInt; Source: PWideChar;
SourceLen: PtrInt; Flags: TCharConversionFlags): PtrInt;
var c: Cardinal;
Tail: PWideChar;
i,j: integer;
label unmatch;
begin
result := PtrInt(Dest);
inc(DestLen,PtrInt(Dest));
if (Source<>nil) and (Dest<>nil) then begin
// first handle 7 bit ASCII WideChars, by pairs (Sha optimization)
SourceLen := SourceLen*2+PtrInt(PtrUInt(Source));
Tail := PWideChar(SourceLen)-2;
if (PtrInt(PtrUInt(Dest))<DestLen) and (Source<=Tail) then
repeat
c := PCardinal(Source)^;
if c and $ff80ff80<>0 then
break; // break on first non ASCII pair
inc(Source,2);
c := c shr 8 or c;
PWord(Dest)^ := c;
inc(Dest,2);
until (Source>Tail) or (PtrInt(PtrUInt(Dest))>=DestLen);
// generic loop, handling one UCS4 char per iteration
if (PtrInt(PtrUInt(Dest))<DestLen) and (PtrInt(PtrUInt(Source))<SourceLen) then
repeat
// inlined UTF16CharToUtf8() with bufferoverlow check and $FFFD on unmatch
c := cardinal(Source^);
inc(Source);
case c of
0..$7f: begin
Dest^ := AnsiChar(c);
inc(Dest);
if (PtrInt(PtrUInt(Dest))<DestLen) and (PtrInt(PtrUInt(Source))<SourceLen) then
continue else break;
end;
UTF16_HISURROGATE_MIN..UTF16_HISURROGATE_MAX:
if (PtrInt(PtrUInt(Source))>=SourceLen) or
((cardinal(Source^)<UTF16_LOSURROGATE_MIN) or (cardinal(Source^)>UTF16_LOSURROGATE_MAX)) then begin
unmatch: if (PtrInt(PtrUInt(@Dest[3]))>DestLen) or
not (ccfReplacementCharacterForUnmatchedSurrogate in Flags) then
break;
PWord(Dest)^ := $BFEF;
Dest[2] := AnsiChar($BD);
inc(Dest,3);
if (PtrInt(PtrUInt(Dest))<DestLen) and (PtrInt(PtrUInt(Source))<SourceLen) then
continue else break;
end else begin
c := ((c-$D7C0)shl 10)+(cardinal(Source^) xor UTF16_LOSURROGATE_MIN);
inc(Source);
end;
UTF16_LOSURROGATE_MIN..UTF16_LOSURROGATE_MAX:
if (PtrInt(PtrUInt(Source))>=SourceLen) or
((cardinal(Source^)<UTF16_HISURROGATE_MIN) or (cardinal(Source^)>UTF16_HISURROGATE_MAX)) then
goto unmatch else begin
c := ((cardinal(Source^)-$D7C0)shl 10)+(c xor UTF16_LOSURROGATE_MIN);
inc(Source);
end;
end; // now c is the UTF-32/UCS4 code point
case c of
0..$7ff: i := 2;
$800..$ffff: i := 3;
$10000..$1FFFFF: i := 4;
$200000..$3FFFFFF: i := 5;
else i := 6;
end;
if PtrInt(PtrUInt(Dest))+i>DestLen then
break;
for j := i-1 downto 1 do begin
Dest[j] := AnsiChar((c and $3f)+$80);
c := c shr 6;
end;
Dest^ := AnsiChar(Byte(c) or UTF8_FIRSTBYTE[i]);
inc(Dest,i);
if (PtrInt(PtrUInt(Dest))<DestLen) and (PtrInt(PtrUInt(Source))<SourceLen) then
continue else break;
until false;
if not (ccfNoTrailingZero in Flags) then
Dest^ := #0;
end;
result := PtrInt(PtrUInt(Dest))-result;
end;
procedure RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer;
var result: RawUTF8; Flags: TCharConversionFlags);
var tmp: TSynTempBuffer;
begin
if (WideChar=nil) or (WideCharCount=0) then
result := '' else begin
tmp.Init(WideCharCount*3);
FastSetString(Result,tmp.buf,RawUnicodeToUtf8(tmp.buf,tmp.len+1,WideChar,WideCharCount,Flags));
tmp.Done;
end;
end;
function RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer;
Flags: TCharConversionFlags): RawUTF8;
begin
RawUnicodeToUTF8(WideChar,WideCharCount,result, Flags);
end;
function RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer; out UTF8Length: integer): RawUTF8;
var LW: integer;
begin
result := ''; // somewhat faster if result is freed before any SetLength()
if WideCharCount=0 then
exit;
LW := WideCharCount*3; // maximum resulting length
SetLength(result,LW);
UTF8Length := RawUnicodeToUtf8(pointer(result),LW+1,WideChar,WideCharCount,[ccfNoTrailingZero]);
if UTF8Length<=0 then
result := '';
end;
/// 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;
begin
SetString(result,WideChar,WideCharCount);
end;
procedure RawUnicodeToWinPChar(dest: PAnsiChar; source: PWideChar; WideCharCount: Integer);
begin
WinAnsiConvert.UnicodeBufferToAnsi(dest,source,WideCharCount);
end;
function RawUnicodeToWinAnsi(WideChar: PWideChar; WideCharCount: integer): WinAnsiString;
begin
result := WinAnsiConvert.UnicodeBufferToAnsi(WideChar,WideCharCount);
end;
function 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;
function Ansi7ToString(const Text: RawByteString): string;
{$ifdef UNICODE}
var i: PtrInt;
begin
SetString(result,nil,length(Text));
for i := 0 to length(Text)-1 do
PWordArray(result)[i] := PByteArray(Text)[i]; // no conversion for 7 bit Ansi
end;
{$else}
begin
result := Text; // if we are SURE this text is 7 bit Ansi -> direct assign
end;
{$endif}
function Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt): string;
begin
{$ifdef UNICODE}
Ansi7ToString(Text,Len,result);
{$else}
SetString(result,PAnsiChar(Text),Len);
{$endif}
end;
procedure Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt; var result: string);
{$ifdef UNICODE}
var i: PtrInt;
begin
SetString(result,nil,Len);
for i := 0 to Len-1 do
PWordArray(result)[i] := PByteArray(Text)[i]; // no conversion for 7 bit Ansi
end;
{$else}
begin
SetString(result,PAnsiChar(Text),Len);
end;
{$endif}
function StringToAnsi7(const Text: string): RawByteString;
{$ifdef UNICODE}
var i: PtrInt;
begin
SetString(result,nil,length(Text));
for i := 0 to length(Text)-1 do
PByteArray(result)[i] := PWordArray(Text)[i]; // no conversion for 7 bit Ansi
end;
{$else}
begin
result := Text; // if we are SURE this text is 7 bit Ansi -> direct assign
end;
{$endif}
function StringToWinAnsi(const Text: string): WinAnsiString;
begin
{$ifdef UNICODE}
result := RawUnicodeToWinAnsi(Pointer(Text),length(Text));
{$else}
result := WinAnsiConvert.AnsiToAnsi(CurrentAnsiConvert,Text);
{$endif}
end;
function StringBufferToUtf8(Dest: PUTF8Char; Source: PChar; SourceChars: PtrInt): PUTF8Char;
begin
{$ifdef UNICODE}
result := Dest+RawUnicodeToUtf8(Dest,SourceChars*3,PWideChar(Source),SourceChars,[]);
{$else}
result := CurrentAnsiConvert.AnsiBufferToUTF8(Dest,Source,SourceChars);
{$endif}
end;
procedure StringBufferToUtf8(Source: PChar; out result: RawUTF8); overload;
begin
{$ifdef UNICODE}
RawUnicodeToUtf8(Source,StrLenW(Source),result);
{$else}
result := CurrentAnsiConvert.AnsiBufferToRawUTF8(Source,StrLen(Source));
{$endif}
end;
function StringToUTF8(const Text: string): RawUTF8;
begin
{$ifdef UNICODE}
RawUnicodeToUtf8(pointer(Text),length(Text),result);
{$else}
result := CurrentAnsiConvert.AnsiToUTF8(Text);
{$endif}
end;
procedure StringToUTF8(Text: PChar; TextLen: PtrInt; var result: RawUTF8);
begin
{$ifdef UNICODE}
RawUnicodeToUtf8(Text,TextLen,result);
{$else}
result := CurrentAnsiConvert.AnsiBufferToRawUTF8(Text, TextLen);
{$endif}
end;
procedure StringToUTF8(const Text: string; var result: RawUTF8);
begin
{$ifdef UNICODE}
RawUnicodeToUtf8(pointer(Text),length(Text),result);
{$else}
result := CurrentAnsiConvert.AnsiToUTF8(Text);
{$endif}
end;
function ToUTF8(const Text: string): RawUTF8;
begin
{$ifdef UNICODE}
RawUnicodeToUtf8(pointer(Text),length(Text),result);
{$else}
result := CurrentAnsiConvert.AnsiToUTF8(Text);
{$endif}
end;
function ToUTF8(const Ansi7Text: ShortString): RawUTF8;
begin
FastSetString(result,@Ansi7Text[1],ord(Ansi7Text[0]));
end;
function ToUTF8({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): RawUTF8;
begin
FastSetString(result,nil,36);
GUIDToText(pointer(result),@guid);
end;
{$ifdef HASVARUSTRING} // some UnicodeString dedicated functions
function UnicodeStringToUtf8(const S: UnicodeString): RawUTF8;
begin
RawUnicodeToUtf8(pointer(S),length(S),result);
end;
function UTF8DecodeToUnicodeString(const S: RawUTF8): UnicodeString;
begin
UTF8DecodeToUnicodeString(pointer(S),length(S),result);
end;
procedure UTF8DecodeToUnicodeString(P: PUTF8Char; L: integer; var result: UnicodeString);
var tmp: TSynTempBuffer;
begin
if (P=nil) or (L=0) then
result := '' else begin
tmp.Init(L*3); // maximum posible unicode size (if all <#128)
SetString(result,PWideChar(tmp.buf),UTF8ToWideChar(tmp.buf,P,L) shr 1);
tmp.Done;
end;
end;
function UnicodeStringToWinAnsi(const S: UnicodeString): WinAnsiString;
begin
result := WinAnsiConvert.UnicodeBufferToAnsi(pointer(S),length(S));
end;
function UTF8DecodeToUnicodeString(P: PUTF8Char; L: integer): UnicodeString;
begin
UTF8DecodeToUnicodeString(P,L,result);
end;
function WinAnsiToUnicodeString(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): UnicodeString;
begin
SetString(result,nil,WinAnsiLen);
WinAnsiConvert.AnsiBufferToUnicode(pointer(result),WinAnsi,WinAnsiLen);
end;
function WinAnsiToUnicodeString(const WinAnsi: WinAnsiString): UnicodeString;
begin
result := WinAnsiToUnicodeString(pointer(WinAnsi),length(WinAnsi));
end;
{$endif HASVARUSTRING}
function StrInt32(P: PAnsiChar; val: PtrInt): PAnsiChar;
{$ifdef ABSOLUTEPASCALORNOTINTEL}
begin // fallback to pure pascal version for ARM or PIC
if val<0 then begin
result := StrUInt32(P,PtrUInt(-val))-1;
result^ := '-';
end else
result := StrUInt32(P,val);
end;
{$else}
{$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; asm {$else}
asm .noframe // rcx=P, rdx=val (Linux: rdi,rsi) - val is QWord on CPUX64
{$endif FPC}
{$ifndef win64}
mov rcx, rdi
mov rdx, rsi
{$endif win64}
mov r10, rdx
sar r10, 63 // r10=0 if val>=0 or -1 if val<0
xor rdx, r10
sub rdx, r10 // rdx=abs(val)
cmp rdx, 10
jb @3 // direct process of common val<10
mov rax, rdx
lea r8, [rip + TwoDigitLookup]
@s: lea rcx, [rcx - 2]
cmp rax, 100
jb @2
lea r9, [rax * 2]
shr rax, 2
mov rdx, 2951479051793528259 // use power of two reciprocal to avoid division
mul rdx
shr rdx, 2
mov rax, rdx
imul rdx, -200
lea rdx, [rdx + r8]
movzx rdx, word ptr[rdx + r9]
mov [rcx], dx
cmp rax, 10
jae @s
@1: or al, '0'
mov byte ptr[rcx - 2], '-'
mov [rcx - 1], al
lea rax, [rcx + r10 - 1] // includes '-' if val<0
ret
@2: movzx eax, word ptr[r8 + rax * 2]
mov byte ptr[rcx - 1], '-'
mov [rcx], ax
lea rax, [rcx + r10] // includes '-' if val<0
ret
@3: or dl, '0'
mov byte ptr[rcx - 2], '-'
mov [rcx - 1], dl
lea rax, [rcx + r10 - 1] // includes '-' if val<0
end;
{$else} {$ifdef FPC} nostackframe; assembler; {$endif}
asm // eax=P, edx=val
mov ecx, edx
sar ecx, 31 // 0 if val>=0 or -1 if val<0
push ecx
xor edx, ecx
sub edx, ecx // edx=abs(val)
cmp edx, 10
jb @3 // direct process of common val<10
push edi
mov edi, eax
mov eax, edx
@s: sub edi, 2
cmp eax, 100
jb @2
mov ecx, eax
mov edx, 1374389535 // use power of two reciprocal to avoid division
mul edx
shr edx, 5 // now edx=eax div 100
mov eax, edx
imul edx, -200
movzx edx, word ptr[TwoDigitLookup + ecx * 2 + edx]
mov [edi], dx
cmp eax, 10
jae @s
@1: dec edi
or al, '0'
mov byte ptr[edi - 1], '-'
mov [edi], al
mov eax, edi
pop edi
pop ecx
add eax, ecx // includes '-' if val<0
ret
@2: movzx eax, word ptr[TwoDigitLookup + eax * 2]
mov byte ptr[edi - 1], '-'
mov [edi], ax
mov eax, edi
pop edi
pop ecx
add eax, ecx // includes '-' if val<0
ret
@3: dec eax
pop ecx
or dl, '0'
mov byte ptr[eax - 1], '-'
mov [eax], dl
add eax, ecx // includes '-' if val<0
end;
{$endif CPUX64}
{$endif ABSOLUTEPASCALORNOTINTEL}
function StrUInt32(P: PAnsiChar; val: PtrUInt): PAnsiChar;
{$ifdef ABSOLUTEPASCALORNOTINTEL} // fallback to pure pascal version for ARM or PIC
var c100: PtrUInt; // val/c100 are QWord on 64-bit CPU
tab: PWordArray;
begin // this code is faster than Borland's original str() or IntToStr()
tab := @TwoDigitLookupW;
repeat
if val<10 then begin
dec(P);
P^ := AnsiChar(val+ord('0'));
break;
end else
if val<100 then begin
dec(P,2);
PWord(P)^ := tab[val];
break;
end;
dec(P,2);
c100 := val div 100;
dec(val,c100*100);
PWord(P)^ := tab[val];
val := c100;
if c100=0 then
break;
until false;
result := P;
end;
{$else}
{$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; asm {$else}
asm .noframe // rcx=P, rdx=val (Linux: rdi,rsi) - val is QWord on CPUX64
{$endif FPC}
{$ifndef win64}
mov rcx, rdi
mov rdx, rsi
{$endif win64}
cmp rdx, 10
jb @3 // direct process of common val<10
mov rax, rdx
lea r8, [rip + TwoDigitLookup]
@s: lea rcx, [rcx - 2]
cmp rax, 100
jb @2
lea r9, [rax * 2]
shr rax, 2
mov rdx, 2951479051793528259 // use power of two reciprocal to avoid division
mul rdx
shr rdx, 2
mov rax, rdx
imul rdx, -200
add rdx, r8
movzx rdx, word ptr[rdx + r9]
mov [rcx], dx
cmp rax, 10
jae @s
@1: dec rcx
or al, '0'
mov [rcx], al
@0: mov rax, rcx
ret
@2: movzx eax, word ptr[r8 + rax * 2]
mov [rcx], ax
mov rax, rcx
ret
@3: lea rax, [rcx - 1]
or dl, '0'
mov [rax], dl
end;
{$else} {$ifdef FPC} nostackframe; assembler; {$endif}
asm // eax=P, edx=val
cmp edx, 10
jb @3 // direct process of common val=0 (or val<10)
push edi
mov edi, eax
mov eax, edx
nop
nop // @s loop alignment
@s: sub edi, 2
cmp eax, 100
jb @2
mov ecx, eax
mov edx, 1374389535 // use power of two reciprocal to avoid division
mul edx
shr edx, 5 // now edx=eax div 100
mov eax, edx
imul edx, -200
movzx edx, word ptr[TwoDigitLookup + ecx * 2 + edx]
mov [edi], dx
cmp eax, 10
jae @s
@1: dec edi
or al, '0'
mov [edi], al
mov eax, edi
pop edi
ret
@2: movzx eax, word ptr[TwoDigitLookup + eax * 2]
mov [edi], ax
mov eax, edi
pop edi
ret
@3: dec eax
or dl, '0'
mov [eax], dl
end;
{$endif CPU64}
{$endif ABSOLUTEPASCALORNOTINTEL}
function StrUInt64(P: PAnsiChar; const val: QWord): PAnsiChar;
{$ifdef CPU64}
begin
result := StrUInt32(P,val); // StrUInt32 converts PtrUInt=QWord on 64-bit CPU
end;
{$else}
var c,c100: QWord;
tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif};
begin
if PInt64Rec(@val)^.Hi=0 then
P := StrUInt32(P,PCardinal(@val)^) else begin
{$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif}
c := val;
repeat
{$ifdef PUREPASCAL}
c100 := c div 100; // one div by two digits
dec(c,c100*100); // fast c := c mod 100
{$else}
asm // by-passing the RTL is a good idea here
push ebx
mov edx, dword ptr[c + 4]
mov eax, dword ptr[c]
mov ebx, 100
mov ecx, eax
mov eax, edx
xor edx, edx
div ebx
mov dword ptr[c100 + 4], eax
xchg eax, ecx
div ebx
mov dword ptr[c100], eax
imul ebx, ecx
mov ecx, 100
mul ecx
add edx, ebx
pop ebx
sub dword ptr[c + 4], edx
sbb dword ptr[c], eax
end;
{$endif}
dec(P,2);
PWord(P)^ := tab[c];
c := c100;
if PInt64Rec(@c)^.Hi=0 then begin
if PCardinal(@c)^<>0 then
P := StrUInt32(P,PCardinal(@c)^);
break;
end;
until false;
end;
result := P;
end;
{$endif}
function StrInt64(P: PAnsiChar; const val: Int64): PAnsiChar;
begin
{$ifdef CPU64}
result := StrInt32(P,val); // StrInt32 converts PtrInt=Int64 on 64-bit CPU
{$else}
if val<0 then begin
P := StrUInt64(P,-val)-1;
P^ := '-';
end else
P := StrUInt64(P,val);
result := P;
{$endif CPU64}
end;
procedure Int32ToUTF8(Value: PtrInt; var result: RawUTF8);
var tmp: array[0..23] of AnsiChar;
P: PAnsiChar;
begin
if PtrUInt(Value)<=high(SmallUInt32UTF8) then
result := SmallUInt32UTF8[Value] else begin
P := StrInt32(@tmp[23],Value);
FastSetString(result,P,@tmp[23]-P);
end;
end;
procedure Int64ToUtf8(Value: Int64; var result: RawUTF8);
var tmp: array[0..23] of AnsiChar;
P: PAnsiChar;
begin
{$ifdef CPU64}
if PtrUInt(Value)<=high(SmallUInt32UTF8) then
{$else} // Int64Rec gives compiler internal error C4963
if (PCardinalArray(@Value)^[0]<=high(SmallUInt32UTF8)) and
(PCardinalArray(@Value)^[1]=0) then
{$endif CPU64}
result := SmallUInt32UTF8[Value] else begin
P := {$ifdef CPU64}StrInt32{$else}StrInt64{$endif}(@tmp[23],Value);
FastSetString(result,P,@tmp[23]-P);
end;
end;
procedure UInt64ToUtf8(Value: QWord; var result: RawUTF8);
var tmp: array[0..23] of AnsiChar;
P: PAnsiChar;
begin
{$ifdef CPU64}
if Value<=high(SmallUInt32UTF8) then
{$else} // Int64Rec gives compiler internal error C4963
if (PCardinalArray(@Value)^[0]<=high(SmallUInt32UTF8)) and
(PCardinalArray(@Value)^[1]=0) then
{$endif CPU64}
result := SmallUInt32UTF8[Value] else begin
P := {$ifdef CPU64}StrUInt32{$else}StrUInt64{$endif}(@tmp[23],Value);
FastSetString(result,P,@tmp[23]-P);
end;
end;
function ClassNameShort(C: TClass): PShortString;
// new TObject.ClassName is UnicodeString (since Delphi 2009) -> inline code
// with vmtClassName = UTF-8 encoded text stored in a shortstring = -44
begin
result := PPointer(PtrInt(PtrUInt(C))+vmtClassName)^;
end;
function ClassNameShort(Instance: TObject): PShortString;
begin
result := PPointer(PPtrInt(Instance)^+vmtClassName)^;
end;
function ToText(C: TClass): RawUTF8;
var P: PShortString;
begin
if C=nil then
result := '' else begin
P := PPointer(PtrInt(PtrUInt(C))+vmtClassName)^;
FastSetString(result,@P^[1],ord(P^[0]));
end;
end;
procedure ToText(C: TClass; var result: RawUTF8);
var P: PShortString;
begin
if C=nil then
result := '' else begin
P := PPointer(PtrInt(PtrUInt(C))+vmtClassName)^;
FastSetString(result,@P^[1],ord(P^[0]));
end;
end;
function GetClassParent(C: TClass): TClass;
begin
result := PPointer(PtrInt(PtrUInt(C))+vmtParent)^;
{$ifndef HASDIRECTTYPEINFO} // e.g. for Delphi and newer FPC
if result<>nil then
result := PPointer(result)^;
{$endif HASDIRECTTYPEINFO}
end;
function VarRecAsChar(const V: TVarRec): integer;
begin
case V.VType of
vtChar: result := ord(V.VChar);
vtWideChar: result := ord(V.VWideChar);
else result := 0;
end;
end;
function VarRecToInt64(const V: TVarRec; out value: Int64): boolean;
begin
case V.VType of
vtInteger: value := V.VInteger;
vtInt64 {$ifdef FPC}, vtQWord{$endif}: value := V.VInt64^;
vtBoolean: if V.VBoolean then value := 1 else value := 0; // normalize
{$ifndef NOVARIANTS}
vtVariant: value := V.VVariant^;
{$endif}
else begin
result := false;
exit;
end;
end;
result := true;
end;
function VarRecToDouble(const V: TVarRec; out value: double): boolean;
begin
case V.VType of
vtInteger: value := V.VInteger;
vtInt64: value := V.VInt64^;
{$ifdef FPC}
vtQWord: value := V.VQWord^;
{$endif}
vtBoolean: if V.VBoolean then value := 1 else value := 0; // normalize
vtExtended: value := V.VExtended^;
vtCurrency: value := V.VCurrency^;
{$ifndef NOVARIANTS}
vtVariant: value := V.VVariant^;
{$endif}
else begin
result := false;
exit;
end;
end;
result := true;
end;
function VarRecToTempUTF8(const V: TVarRec; var Res: TTempUTF8): integer;
{$ifndef NOVARIANTS}
var v64: Int64;
isString: boolean;
{$endif}
label smlu32;
begin
Res.TempRawUTF8 := nil; // avoid GPF
case V.VType of
vtString: begin
Res.Text := @V.VString^[1];
Res.Len := ord(V.VString^[0]);
result := Res.Len;
exit;
end;
vtAnsiString: begin // expect UTF-8 content
Res.Text := pointer(V.VAnsiString);
Res.Len := length(RawUTF8(V.VAnsiString));
result := Res.Len;
exit;
end;
{$ifdef HASVARUSTRING}
vtUnicodeString:
RawUnicodeToUtf8(V.VPWideChar,length(UnicodeString(V.VUnicodeString)),RawUTF8(Res.TempRawUTF8));
{$endif}
vtWideString:
RawUnicodeToUtf8(V.VPWideChar,length(WideString(V.VWideString)),RawUTF8(Res.TempRawUTF8));
vtPChar: begin // expect UTF-8 content
Res.Text := V.VPointer;
Res.Len := StrLen(V.VPointer);
result := Res.Len;
exit;
end;
vtChar: begin
Res.Temp[0] := V.VChar; // V may be on transient stack (alf: FPC)
Res.Text := @Res.Temp;
Res.Len := 1;
result := 1;
exit;
end;
vtPWideChar:
RawUnicodeToUtf8(V.VPWideChar,StrLenW(V.VPWideChar),RawUTF8(Res.TempRawUTF8));
vtWideChar:
RawUnicodeToUtf8(@V.VWideChar,1,RawUTF8(Res.TempRawUTF8));
vtBoolean: begin
if V.VBoolean then // normalize
Res.Text := pointer(SmallUInt32UTF8[1]) else
Res.Text := pointer(SmallUInt32UTF8[0]);
Res.Len := 1;
result := 1;
exit;
end;
vtInteger: begin
result := V.VInteger;
if cardinal(result)<=high(SmallUInt32UTF8) then begin
smlu32: Res.Text := pointer(SmallUInt32UTF8[result]);
Res.Len := PStrLen(Res.Text-_STRLEN)^;
end else begin
Res.Text := PUTF8Char(StrInt32(@Res.Temp[23],result));
Res.Len := @Res.Temp[23]-Res.Text;
end;
result := Res.Len;
exit;
end;
vtInt64:
if (PCardinalArray(V.VInt64)^[0]<=high(SmallUInt32UTF8)) and
(PCardinalArray(V.VInt64)^[1]=0) then begin
result := V.VInt64^;
goto smlu32;
end else begin
Res.Text := PUTF8Char(StrInt64(@Res.Temp[23],V.VInt64^));
Res.Len := @Res.Temp[23]-Res.Text;
result := Res.Len;
exit;
end;
{$ifdef FPC}
vtQWord:
if V.VQWord^<=high(SmallUInt32UTF8) then begin
result := V.VQWord^;
goto smlu32;
end else begin
Res.Text := PUTF8Char(StrUInt64(@Res.Temp[23],V.VQWord^));
Res.Len := @Res.Temp[23]-Res.Text;
result := Res.Len;
exit;
end;
{$endif}
vtCurrency: begin
Res.Text := @Res.Temp;
Res.Len := Curr64ToPChar(V.VInt64^,Res.Temp);
result := Res.Len;
exit;
end;
vtExtended:
DoubleToStr(V.VExtended^,RawUTF8(Res.TempRawUTF8));
vtPointer,vtInterface: begin
Res.Text := @Res.Temp;
Res.Len := SizeOf(pointer)*2;
BinToHexDisplayLower(@V.VPointer,@Res.Temp,SizeOf(Pointer));
result := SizeOf(pointer)*2;
exit;
end;
vtClass: begin
if V.VClass<>nil then begin
Res.Text := PPUTF8Char(PtrInt(PtrUInt(V.VClass))+vmtClassName)^+1;
Res.Len := ord(Res.Text[-1]);
end else
Res.Len := 0;
result := Res.Len;
exit;
end;
vtObject: begin
if V.VObject<>nil then begin
Res.Text := PPUTF8Char(PPtrInt(V.VObject)^+vmtClassName)^+1;
Res.Len := ord(Res.Text[-1]);
end else
Res.Len := 0;
result := Res.Len;
exit;
end;
{$ifndef NOVARIANTS}
vtVariant:
if VariantToInt64(V.VVariant^,v64) then
if (PCardinalArray(@v64)^[0]<=high(SmallUInt32UTF8)) and
(PCardinalArray(@v64)^[1]=0) then begin
result := v64;
goto smlu32;
end else begin
Res.Text := PUTF8Char(StrInt64(@Res.Temp[23],v64));
Res.Len := @Res.Temp[23]-Res.Text;
result := Res.Len;
exit;
end else
VariantToUTF8(V.VVariant^,RawUTF8(Res.TempRawUTF8),isString);
{$endif}
else begin
Res.Len := 0;
result := 0;
exit;
end;
end;
Res.Text := Res.TempRawUTF8;
Res.Len := length(RawUTF8(Res.TempRawUTF8));
result := Res.Len;
end;
procedure VarRecToUTF8(const V: TVarRec; var result: RawUTF8; wasString: PBoolean);
var isString: boolean;
begin
isString := not (V.VType in [
vtBoolean,vtInteger,vtInt64{$ifdef FPC},vtQWord{$endif},vtCurrency,vtExtended]);
with V do
case V.VType of
vtString:
FastSetString(result,@VString^[1],ord(VString^[0]));
vtAnsiString:
result := RawUTF8(VAnsiString); // expect UTF-8 content
{$ifdef HASVARUSTRING}
vtUnicodeString:
RawUnicodeToUtf8(VUnicodeString,length(UnicodeString(VUnicodeString)),result);
{$endif}
vtWideString:
RawUnicodeToUtf8(VWideString,length(WideString(VWideString)),result);
vtPChar:
FastSetString(result,VPChar,StrLen(VPChar));
vtChar:
FastSetString(result,PAnsiChar(@VChar),1);
vtPWideChar:
RawUnicodeToUtf8(VPWideChar,StrLenW(VPWideChar),result);
vtWideChar:
RawUnicodeToUtf8(@VWideChar,1,result);
vtBoolean:
if VBoolean then // normalize
result := SmallUInt32UTF8[1] else
result := SmallUInt32UTF8[0];
vtInteger:
Int32ToUtf8(VInteger,result);
vtInt64:
Int64ToUtf8(VInt64^,result);
{$ifdef FPC}
vtQWord:
UInt64ToUtf8(VQWord^,result);
{$endif}
vtCurrency:
Curr64ToStr(VInt64^,result);
vtExtended:
DoubleToStr(VExtended^,result);
vtPointer:
PointerToHex(VPointer,result);
vtClass:
if VClass<>nil then
ToText(VClass,result) else
result := '';
vtObject:
if VObject<>nil then
ToText(PClass(VObject)^,result) else
result := '';
vtInterface:
{$ifdef HASINTERFACEASTOBJECT}
if VInterface<>nil then
ToText((IInterface(VInterface) as TObject).ClassType,result) else
result := '';
{$else}
PointerToHex(VInterface,result);
{$endif}
{$ifndef NOVARIANTS}
vtVariant:
VariantToUTF8(VVariant^,result,isString);
{$endif}
else begin
isString := false;
result := '';
end;
end;
if wasString<>nil then
wasString^ := isString;
end;
function VarRecToUTF8IsString(const V: TVarRec; var value: RawUTF8): boolean;
begin
VarRecToUTF8(V,value,@result);
end;
procedure VarRecToInlineValue(const V: TVarRec; var result: RawUTF8);
var wasString: boolean;
tmp: RawUTF8;
begin
VarRecToUTF8(V,tmp,@wasString);
if wasString then
QuotedStr(tmp,'"',result) else
result := tmp;
end;
{$ifdef UNICODE}
function StringToRawUnicode(const S: string): RawUnicode;
begin
SetString(result,PAnsiChar(pointer(S)),length(S)*2+1); // +1 for last wide #0
end;
function StringToSynUnicode(const S: string): SynUnicode;
begin
result := S;
end;
procedure StringToSynUnicode(const S: string; var result: SynUnicode); overload;
begin
result := S;
end;
function StringToRawUnicode(P: PChar; L: integer): RawUnicode;
begin
SetString(result,PAnsiChar(P),L*2+1); // +1 for last wide #0
end;
function RawUnicodeToString(P: PWideChar; L: integer): string;
begin
SetString(result,P,L);
end;
procedure RawUnicodeToString(P: PWideChar; L: integer; var result: string);
begin
SetString(result,P,L);
end;
function RawUnicodeToString(const U: RawUnicode): string;
begin // uses StrLenW() and not length(U) to handle case when was used as buffer
SetString(result,PWideChar(pointer(U)),StrLenW(Pointer(U)));
end;
function SynUnicodeToString(const U: SynUnicode): string;
begin
result := U;
end;
function UTF8DecodeToString(P: PUTF8Char; L: integer): string;
begin
UTF8DecodeToUnicodeString(P,L,result);
end;
procedure UTF8DecodeToString(P: PUTF8Char; L: integer; var result: string);
begin
UTF8DecodeToUnicodeString(P,L,result);
end;
function UTF8ToString(const Text: RawUTF8): string;
begin
UTF8DecodeToUnicodeString(pointer(Text),length(Text),result);
end;
{$else}
function StringToRawUnicode(const S: string): RawUnicode;
begin
result := CurrentAnsiConvert.AnsiToRawUnicode(S);
end;
function StringToSynUnicode(const S: string): SynUnicode;
begin
result := CurrentAnsiConvert.AnsiToUnicodeString(pointer(S),length(S));
end;
procedure StringToSynUnicode(const S: string; var result: SynUnicode); overload;
begin
result := CurrentAnsiConvert.AnsiToUnicodeString(pointer(S),length(S));
end;
function StringToRawUnicode(P: PChar; L: integer): RawUnicode;
begin
result := CurrentAnsiConvert.AnsiToRawUnicode(P,L);
end;
function RawUnicodeToString(P: PWideChar; L: integer): string;
begin
result := CurrentAnsiConvert.UnicodeBufferToAnsi(P,L);
end;
procedure RawUnicodeToString(P: PWideChar; L: integer; var result: string);
begin
result := CurrentAnsiConvert.UnicodeBufferToAnsi(P,L);
end;
function RawUnicodeToString(const U: RawUnicode): string;
begin // uses StrLenW() and not length(U) to handle case when was used as buffer
result := CurrentAnsiConvert.UnicodeBufferToAnsi(Pointer(U),StrLenW(Pointer(U)));
end;
function SynUnicodeToString(const U: SynUnicode): string;
begin
result := CurrentAnsiConvert.UnicodeBufferToAnsi(Pointer(U),length(U));
end;
function UTF8DecodeToString(P: PUTF8Char; L: integer): string;
begin
CurrentAnsiConvert.UTF8BufferToAnsi(P,L,RawByteString(result));
end;
procedure UTF8DecodeToString(P: PUTF8Char; L: integer; var result: string);
begin
CurrentAnsiConvert.UTF8BufferToAnsi(P,L,RawByteString(result));
end;
function UTF8ToString(const Text: RawUTF8): string;
begin
CurrentAnsiConvert.UTF8BufferToAnsi(pointer(Text),length(Text),RawByteString(result));
end;
{$endif UNICODE}
procedure UTF8ToWideString(const Text: RawUTF8; var result: WideString);
begin
UTF8ToWideString(pointer(Text),Length(Text),result);
end;
function UTF8ToWideString(const Text: RawUTF8): WideString;
begin
{$ifdef FPC}
Finalize(result);
{$endif FPC}
UTF8ToWideString(pointer(Text),Length(Text),result);
end;
procedure UTF8ToWideString(Text: PUTF8Char; Len: PtrInt; var result: WideString);
var tmp: TSynTempBuffer;
begin
if (Text=nil) or (Len=0) then
result := '' else begin
tmp.Init(Len*3); // maximum posible unicode size (if all <#128)
SetString(result,PWideChar(tmp.buf),UTF8ToWideChar(tmp.buf,Text,Len) shr 1);
tmp.Done;
end;
end;
function WideStringToUTF8(const aText: WideString): RawUTF8;
begin
RawUnicodeToUtf8(pointer(aText),length(aText),result);
end;
function UTF8ToSynUnicode(const Text: RawUTF8): SynUnicode;
begin
UTF8ToSynUnicode(pointer(Text),length(Text),result);
end;
procedure UTF8ToSynUnicode(const Text: RawUTF8; var result: SynUnicode);
begin
UTF8ToSynUnicode(pointer(Text),length(Text),result);
end;
procedure UTF8ToSynUnicode(Text: PUTF8Char; Len: PtrInt; var result: SynUnicode);
var tmp: TSynTempBuffer;
begin
if (Text=nil) or (Len=0) then
result := '' else begin
tmp.Init(Len*3); // maximum posible unicode size (if all <#128)
SetString(result,PWideChar(tmp.buf),UTF8ToWideChar(tmp.buf,Text,Len) shr 1);
tmp.Done;
end;
end;
{ TRawUTF8InterningSlot }
procedure TRawUTF8InterningSlot.Init;
begin
Safe.Init;
{$ifndef NOVARIANTS}
Safe.LockedInt64[0] := 0;
{$endif}
Values.Init(TypeInfo(TRawUTF8DynArray),Value,HashAnsiString,
SortDynArrayAnsiString,InterningHasher,@Safe.Padding[0].VInteger,false);
end;
procedure TRawUTF8InterningSlot.Done;
begin
Safe.Done;
end;
function TRawUTF8InterningSlot.Count: integer;
begin
{$ifdef NOVARIANTS}
result := Safe.Padding[0].VInteger;
{$else}
result := Safe.LockedInt64[0];
{$endif}
end;
procedure TRawUTF8InterningSlot.Unique(var aResult: RawUTF8;
const aText: RawUTF8; aTextHash: cardinal);
var i: PtrInt;
added: boolean;
begin
EnterCriticalSection(Safe.fSection);
try
i := Values.FindHashedForAdding(aText,added,aTextHash);
if added then begin
Value[i] := aText; // copy new value to the pool
aResult := aText;
end else
aResult := Value[i]; // return unified string instance
finally
LeaveCriticalSection(Safe.fSection);
end;
end;
procedure TRawUTF8InterningSlot.UniqueText(var aText: RawUTF8; aTextHash: cardinal);
var i: PtrInt;
added: boolean;
begin
EnterCriticalSection(Safe.fSection);
try
i := Values.FindHashedForAdding(aText,added,aTextHash);
if added then
Value[i] := aText else // copy new value to the pool
aText := Value[i]; // return unified string instance
finally
LeaveCriticalSection(Safe.fSection);
end;
end;
procedure TRawUTF8InterningSlot.Clear;
begin
EnterCriticalSection(Safe.fSection);
try
Values.SetCount(0); // Values.Clear
Values.Hasher.Clear;
finally
LeaveCriticalSection(Safe.fSection);
end;
end;
function TRawUTF8InterningSlot.Clean(aMaxRefCount: integer): integer;
var i: integer;
s,d: PPtrUInt; // points to RawUTF8 values (bypass COW assignments)
begin
result := 0;
EnterCriticalSection(Safe.fSection);
try
if Safe.Padding[0].VInteger=0 then
exit;
s := pointer(Value);
d := s;
for i := 1 to Safe.Padding[0].VInteger do begin
if PStrCnt(PAnsiChar(s^)-_STRREFCNT)^<=aMaxRefCount then begin
{$ifdef FPC}
Finalize(PRawUTF8(s)^);
{$else}
PRawUTF8(s)^ := '';
{$endif FPC}
inc(result);
end else begin
if s<>d then begin
d^ := s^;
s^ := 0; // avoid GPF
end;
inc(d);
end;
inc(s);
end;
if result>0 then begin
Values.SetCount((PtrUInt(d)-PtrUInt(Value))div SizeOf(d^));
Values.ReHash;
end;
finally
LeaveCriticalSection(Safe.fSection);
end;
end;
{ TRawUTF8Interning }
constructor TRawUTF8Interning.Create(aHashTables: integer);
var p: integer;
i: PtrInt;
begin
for p := 0 to 9 do
if aHashTables=1 shl p then begin
SetLength(fPool,aHashTables);
fPoolLast := aHashTables-1;
for i := 0 to fPoolLast do
fPool[i].Init;
exit;
end;
raise ESynException.CreateUTF8('%.Create(%) not allowed: should be a power of 2',
[self,aHashTables]);
end;
destructor TRawUTF8Interning.Destroy;
var i: PtrInt;
begin
for i := 0 to fPoolLast do
fPool[i].Done;
inherited Destroy;
end;
procedure TRawUTF8Interning.Clear;
var i: PtrInt;
begin
if self<>nil then
for i := 0 to fPoolLast do
fPool[i].Clear;
end;
function TRawUTF8Interning.Clean(aMaxRefCount: integer): integer;
var i: PtrInt;
begin
result := 0;
if self<>nil then
for i := 0 to fPoolLast do
inc(result,fPool[i].Clean(aMaxRefCount));
end;
function TRawUTF8Interning.Count: integer;
var i: PtrInt;
begin
result := 0;
if self<>nil then
for i := 0 to fPoolLast do
inc(result,fPool[i].Count);
end;
procedure TRawUTF8Interning.Unique(var aResult: RawUTF8; const aText: RawUTF8);
var hash: cardinal;
begin
if aText='' then
aResult := '' else
if self=nil then
aResult := aText else begin
hash := InterningHasher(0,pointer(aText),length(aText)); // = fPool[].Values.HashElement
fPool[hash and fPoolLast].Unique(aResult,aText,hash);
end;
end;
procedure TRawUTF8Interning.UniqueText(var aText: RawUTF8);
var hash: cardinal;
begin
if (self<>nil) and (aText<>'') then begin
hash := InterningHasher(0,pointer(aText),length(aText)); // = fPool[].Values.HashElement
fPool[hash and fPoolLast].UniqueText(aText,hash);
end;
end;
function TRawUTF8Interning.Unique(const aText: RawUTF8): RawUTF8;
var hash: cardinal;
begin
if aText='' then
result := '' else
if self=nil then
result := aText else begin
hash := InterningHasher(0,pointer(aText),length(aText)); // = fPool[].Values.HashElement
fPool[hash and fPoolLast].Unique(result,aText,hash);
end;
end;
function TRawUTF8Interning.Unique(aText: PUTF8Char; aTextLen: PtrInt): RawUTF8;
begin
FastSetString(result,aText,aTextLen);
UniqueText(result);
end;
procedure TRawUTF8Interning.Unique(var aResult: RawUTF8; aText: PUTF8Char;
aTextLen: PtrInt);
begin
FastSetString(aResult,aText,aTextLen);
UniqueText(aResult);
end;
procedure ClearVariantForString(var Value: variant); {$ifdef HASINLINE} inline; {$endif}
var v: TVarData absolute Value;
begin
if cardinal(v.VType) = varString then
Finalize(RawByteString(v.VString))
else
begin
VarClear(Value);
PInteger(@v.VType)^ := varString;
v.VString := nil; // to avoid GPF when assign a RawByteString
end;
end;
{$ifndef NOVARIANTS}
procedure TRawUTF8Interning.UniqueVariant(var aResult: variant; const aText: RawUTF8);
begin
ClearVariantForString(aResult);
Unique(RawUTF8(TVarData(aResult).VAny),aText);
end;
procedure TRawUTF8Interning.UniqueVariantString(var aResult: variant; const aText: string);
var tmp: RawUTF8;
begin
StringToUTF8(aText,tmp);
UniqueVariant(aResult,tmp);
end;
procedure TRawUTF8Interning.UniqueVariant(var aResult: variant;
aText: PUTF8Char; aTextLen: PtrInt; aAllowVarDouble: boolean);
var tmp: RawUTF8;
begin
if not GetNumericVariantFromJSON(aText,TVarData(aResult),aAllowVarDouble) then begin
FastSetString(tmp,aText,aTextLen);
UniqueVariant(aResult,tmp);
end;
end;
procedure TRawUTF8Interning.UniqueVariant(var aResult: variant);
var vt: cardinal;
begin
vt := TVarData(aResult).VType;
with TVarData(aResult) do
if vt=varString then
UniqueText(RawUTF8(VString)) else
if vt=varVariant or varByRef then
UniqueVariant(PVariant(VPointer)^) else
if vt=varString or varByRef then
UniqueText(PRawUTF8(VPointer)^);
end;
{$endif NOVARIANTS}
const
// see https://en.wikipedia.org/wiki/Baudot_code
Baudot2Char: array[0..63] of AnsiChar =
#0'e'#10'a siu'#13'drjnfcktzlwhypqobg'#254'mxv'#255+
#0'3'#10'- ''87'#13#0'4'#0',!:(5+)2$6019?@'#254'./;'#255;
var
Char2Baudot: array[AnsiChar] of byte;
function AsciiToBaudot(const Text: RawUTF8): RawByteString;
begin
result := AsciiToBaudot(pointer(Text),length(Text));
end;
function AsciiToBaudot(P: PAnsiChar; len: PtrInt): RawByteString;
var i: PtrInt;
c,d,bits: integer;
shift: boolean;
dest: PByte;
tmp: TSynTempBuffer;
begin
result := '';
if (P=nil) or (len=0) then
exit;
shift := false;
dest := tmp.Init((len*10)shr 3);
d := 0;
bits := 0;
for i := 0 to len-1 do begin
c := Char2Baudot[P[i]];
if c>32 then begin
if not shift then begin
d := (d shl 5) or 27;
inc(bits,5);
shift := true;
end;
d := (d shl 5) or (c-32);
inc(bits,5);
end else
if c>0 then begin
if shift and (P[i]>=' ') then begin
d := (d shl 5) or 31;
inc(bits,5);
shift := false;
end;
d := (d shl 5) or c;
inc(bits,5);
end;
while bits>=8 do begin
dec(bits,8);
dest^ := d shr bits;
inc(dest);
end;
end;
if bits>0 then begin
dest^ := d shl (8-bits);
inc(dest);
end;
SetString(result,PAnsiChar(tmp.buf),PAnsiChar(dest)-PAnsiChar(tmp.buf));
tmp.Done;
end;
function BaudotToAscii(const Baudot: RawByteString): RawUTF8;
begin
result := BaudotToAscii(pointer(Baudot),length(Baudot));
end;
function BaudotToAscii(Baudot: PByteArray; len: PtrInt): RawUTF8;
var i: PtrInt;
c,b,bits,shift: integer;
tmp: TSynTempBuffer;
dest: PAnsiChar;
begin
result := '';
if (Baudot=nil) or (len<=0) then
exit;
dest := tmp.Init((len shl 3)div 5);
try
shift := 0;
b := 0;
bits := 0;
for i := 0 to len-1 do begin
b := (b shl 8) or Baudot[i];
inc(bits,8);
while bits>=5 do begin
dec(bits,5);
c := (b shr bits) and 31;
case c of
27: if shift<>0 then
exit else
shift := 32;
31: if shift<>0 then
shift := 0 else
exit;
else begin
c := ord(Baudot2Char[c+shift]);
if c=0 then
if Baudot[i+1]=0 then // allow triming of last 5 bits
break else
exit;
dest^ := AnsiChar(c);
inc(dest);
end;
end;
end;
end;
finally
tmp.Done(dest,result);
end;
end;
function IsVoid(const text: RawUTF8): boolean;
var i: PtrInt;
begin
result := false;
for i := 1 to length(text) do
if text[i]>' ' then
exit;
result := true;
end;
function TrimControlChars(const text: RawUTF8; const controls: TSynAnsicharSet): RawUTF8;
var len,i,j,n: PtrInt;
P: PAnsiChar;
begin
len := length(text);
for i := 1 to len do
if text[i] in controls then begin
n := i-1;
FastSetString(result,nil,len);
P := pointer(result);
if n>0 then
MoveFast(pointer(text)^,P^,n);
for j := i+1 to len do
if not(text[j] in controls) then begin
P[n] := text[j];
inc(n);
end;
SetLength(result,n); // truncate
exit;
end;
result := text; // no control char found
end;
procedure ExchgPointer(n1,n2: PPointer); {$ifdef HASINLINE}inline;{$endif}
var n: pointer;
begin
n := n2^;
n2^ := n1^;
n1^ := n;
end;
procedure ExchgVariant(v1,v2: PPtrIntArray); {$ifdef CPU64}inline;{$endif}
var c: PtrInt; // 32-bit:16bytes=4ptr 64-bit:24bytes=3ptr
begin
c := v2[0];
v2[0] := v1[0];
v1[0] := c;
c := v2[1];
v2[1] := v1[1];
v1[1] := c;
c := v2[2];
v2[2] := v1[2];
v1[2] := c;
{$ifdef CPU32}
c := v2[3];
v2[3] := v1[3];
v1[3] := c;
{$endif}
end;
{$ifdef CPU64}
procedure Exchg16(P1,P2: PPtrIntArray); inline;
var c: PtrInt;
begin
c := P1[0];
P1[0] := P2[0];
P2[0] := c;
c := P1[1];
P1[1] := P2[1];
P2[1] := c;
end;
{$endif}
procedure Exchg(P1,P2: PAnsiChar; count: PtrInt);
{$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif}
var i, c: PtrInt;
u: AnsiChar;
begin
for i := 1 to count shr POINTERSHR do begin
c := PPtrInt(P1)^;
PPtrInt(P1)^ := PPtrInt(P2)^;
PPtrInt(P2)^ := c;
inc(P1,SizeOf(c));
inc(P2,SizeOf(c));
end;
for i := 0 to (count and POINTERAND)-1 do begin
u := P1[i];
P1[i] := P2[i];
P2[i] := u;
end;
end;
{$else} {$ifdef FPC} nostackframe; assembler; {$endif}
asm // eax=P1, edx=P2, ecx=count
push ebx
push esi
push ecx
shr ecx, 2
jz @2
@4: mov ebx, [eax]
mov esi, [edx]
mov [eax], esi
mov [edx], ebx
add eax, 4
add edx, 4
dec ecx
jnz @4
@2: pop ecx
and ecx, 3
jz @0
@1: mov bl, [eax]
mov bh, [edx]
mov [eax], bh
mov [edx], bl
inc eax
inc edx
dec ecx
jnz @1
@0: pop esi
pop ebx
end;
{$endif}
function GetAllBits(Bits, BitCount: Cardinal): boolean;
begin
if BitCount in [low(ALLBITS_CARDINAL)..high(ALLBITS_CARDINAL)] then begin
BitCount := ALLBITS_CARDINAL[BitCount];
result := (Bits and BitCount)=BitCount;
end else
result := false;
end;
// naive code gives the best performance - bts [Bits] has an overhead
function GetBit(const Bits; aIndex: PtrInt): boolean;
begin
result := PByteArray(@Bits)[aIndex shr 3] and (1 shl (aIndex and 7)) <> 0;
end;
procedure SetBit(var Bits; aIndex: PtrInt);
begin
TByteArray(Bits)[aIndex shr 3] := TByteArray(Bits)[aIndex shr 3]
or (1 shl (aIndex and 7));
end;
procedure UnSetBit(var Bits; aIndex: PtrInt);
begin
PByteArray(@Bits)[aIndex shr 3] := PByteArray(@Bits)[aIndex shr 3]
and not (1 shl (aIndex and 7));
end;
function GetBitPtr(Bits: pointer; aIndex: PtrInt): boolean;
begin
result := PByteArray(Bits)[aIndex shr 3] and (1 shl (aIndex and 7)) <> 0;
end;
procedure SetBitPtr(Bits: pointer; aIndex: PtrInt);
begin
PByteArray(Bits)[aIndex shr 3] := PByteArray(Bits)[aIndex shr 3]
or (1 shl (aIndex and 7));
end;
procedure UnSetBitPtr(Bits: pointer; aIndex: PtrInt);
begin
PByteArray(Bits)[aIndex shr 3] := PByteArray(Bits)[aIndex shr 3]
and not (1 shl (aIndex and 7));
end;
function GetBit64(const Bits: Int64; aIndex: PtrInt): boolean;
begin
result := aIndex in TBits64(Bits);
end;
procedure SetBit64(var Bits: Int64; aIndex: PtrInt);
begin
include(PBits64(@Bits)^,aIndex);
end;
procedure UnSetBit64(var Bits: Int64; aIndex: PtrInt);
begin
exclude(PBits64(@Bits)^,aIndex);
end;
function GetBitsCount(const Bits; Count: PtrInt): PtrInt;
var P: PPtrInt;
popcnt: function(value: PtrInt): PtrInt; // fast redirection within loop
begin
P := @Bits;
result := 0;
popcnt := @GetBitsCountPtrInt;
if Count>=POINTERBITS then
repeat
dec(Count,POINTERBITS);
inc(result,popcnt(P^)); // use SSE4.2 if available
inc(P);
until Count<POINTERBITS;
if Count>0 then
inc(result,popcnt(P^ and ((PtrInt(1) shl Count)-1)));
end;
{ FPC x86_64 Linux:
1000000 pas in 4.67ms i.e. 213,949,507/s, aver. 0us, 1.5 GB/s
1000000 asm in 4.14ms i.e. 241,196,333/s, aver. 0us, 1.8 GB/s
1000000 sse4.2 in 2.36ms i.e. 423,011,844/s, aver. 0us, 3.1 GB/s
1000000 FPC in 21.32ms i.e. 46,886,721/s, aver. 0us, 357.7 MB/s
FPC i386 Windows:
1000000 pas in 3.40ms i.e. 293,944,738/s, aver. 0us, 1 GB/s
1000000 asm in 3.18ms i.e. 313,971,742/s, aver. 0us, 1.1 GB/s
1000000 sse4.2 in 2.74ms i.e. 364,166,059/s, aver. 0us, 1.3 GB/s
1000000 FPC in 8.18ms i.e. 122,204,570/s, aver. 0us, 466.1 MB/s
notes:
1. AVX2 faster than popcnt on big buffers - https://arxiv.org/pdf/1611.07612.pdf
2. our pascal/asm versions below use the efficient Wilkes-Wheeler-Gill algorithm
whereas FPC RTL's popcnt() is much slower }
{$ifdef CPUX86}
function GetBitsCountSSE42(value: PtrInt): PtrInt; {$ifdef FPC} nostackframe; assembler; {$endif}
asm
{$ifdef FPC_X86ASM}
popcnt eax, eax
{$else} // oldest Delphi don't support this opcode
db $f3,$0f,$B8,$c0
{$endif}
end;
function GetBitsCountPas(value: PtrInt): PtrInt; {$ifdef FPC} nostackframe; assembler; {$endif}
asm // branchless Wilkes-Wheeler-Gill i386 asm implementation
mov edx, eax
shr eax, 1
and eax, $55555555
sub edx, eax
mov eax, edx
shr edx, 2
and eax, $33333333
and edx, $33333333
add eax, edx
mov edx, eax
shr eax, 4
add eax, edx
and eax, $0f0f0f0f
mov edx, eax
shr edx, 8
add eax, edx
mov edx, eax
shr edx, 16
add eax, edx
and eax, $3f
end;
{$else}
{$ifdef CPUX64}
function GetBitsCountSSE42(value: PtrInt): PtrInt;
{$ifdef FPC} assembler; nostackframe;
asm
popcnt rax, value
{$else} // oldest Delphi don't support this opcode
asm .noframe
{$ifdef win64} db $f3,$48,$0f,$B8,$c1
{$else} db $f3,$48,$0f,$B8,$c7 {$endif}
{$endif FPC}
end;
function GetBitsCountPas(value: PtrInt): PtrInt;
{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif}
mov rax, value
mov rdx, value
shr rax, 1
mov rcx, $5555555555555555
mov r8, $3333333333333333
mov r10, $0f0f0f0f0f0f0f0f
mov r11, $0101010101010101
and rax, rcx
sub rdx, rax
mov rax, rdx
shr rdx, 2
and rax, r8
and rdx, r8
add rax, rdx
mov rdx, rax
shr rax, 4
add rax, rdx
and rax, r10
imul rax, r11
shr rax, 56
end;
{$else}
function GetBitsCountPas(value: PtrInt): PtrInt;
begin // generic branchless Wilkes-Wheeler-Gill pure pascal version
result := value;
{$ifdef CPU64}
result := result-((result shr 1) and $5555555555555555);
result := (result and $3333333333333333)+((result shr 2) and $3333333333333333);
result := (result+(result shr 4)) and $0f0f0f0f0f0f0f0f;
inc(result,result shr 8); // avoid slow multiplication on ARM
inc(result,result shr 16);
inc(result,result shr 32);
result := result and $7f;
{$else}
result := result-((result shr 1) and $55555555);
result := (result and $33333333)+((result shr 2) and $33333333);
result := (result+(result shr 4)) and $0f0f0f0f;
inc(result,result shr 8);
inc(result,result shr 16);
result := result and $3f;
{$endif CPU64}
end;
{$endif CPUX64}
{$endif CPUX86}
type
{$ifdef FPC}
{$packrecords c} // as expected by FPC's RTTI record definitions
TStrRec = record // see TAnsiRec/TUnicodeRec in astrings/ustrings.inc
{$ifdef ISFPC27}
codePage: TSystemCodePage; // =Word
elemSize: Word;
{$ifndef STRCNT32}
{$ifdef CPU64}
_PaddingToQWord: DWord;
{$endif} {$endif} {$endif}
refCnt: TStrCnt; // =SizeInt on older FPC, =longint since FPC 3.4
length: SizeInt;
end;
{$else FPC}
/// map the Delphi/FPC dynamic array header (stored before each instance)
TDynArrayRec = packed record
{$ifdef CPUX64}
/// padding bytes for 16 byte alignment of the header
_Padding: LongInt;
{$endif}
/// dynamic array reference count (basic garbage memory mechanism)
refCnt: TDACnt;
/// length in element count
// - size in bytes = length*ElemSize
length: PtrInt;
end;
PDynArrayRec = ^TDynArrayRec;
/// map the Delphi/FPC string header (stored before each instance)
TStrRec = packed record
{$ifdef UNICODE}
{$ifdef CPU64}
/// padding bytes for 16 bytes alignment of the header
_Padding: LongInt;
{$endif}
/// the associated code page used for this string
// - exist only since Delphi/FPC 2009
// - 0 or 65535 for RawByteString
// - 1200=CP_UTF16 for UnicodeString
// - 65001=CP_UTF8 for RawUTF8
// - the current code page for AnsiString
codePage: Word;
/// either 1 (for AnsiString) or 2 (for UnicodeString)
// - exist only since Delphi/FPC 2009
elemSize: Word;
{$endif UNICODE}
/// COW string reference count (basic garbage memory mechanism)
refCnt: TStrCnt;
/// length in characters
// - size in bytes = length*elemSize
length: Longint;
end;
{$endif FPC}
PStrRec = ^TStrRec;
PTypeInfo = ^TTypeInfo;
{$ifdef HASDIRECTTYPEINFO} // for old FPC (<=3.0)
PTypeInfoStored = PTypeInfo;
{$else} // e.g. for Delphi and newer FPC
PTypeInfoStored = ^PTypeInfo; // = TypeInfoPtr macro in FPC typinfo.pp
{$endif}
// note: FPC TRecInitData is taken from typinfo.pp via SynFPCTypInfo
// since this information is evolving/breaking a lot in the current FPC trunk
/// map the Delphi/FPC record field RTTI
TFieldInfo =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
TypeInfo: PTypeInfoStored;
{$ifdef FPC}
Offset: sizeint;
{$else}
Offset: PtrUInt;
{$endif FPC}
end;
PFieldInfo = ^TFieldInfo;
{$ifdef ISDELPHI2010_OR_FPC_NEWRTTI}
/// map the Delphi record field enhanced RTTI (available since Delphi 2010)
TEnhancedFieldInfo =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
TypeInfo: PTypeInfoStored;
{$ifdef FPC}
Offset: sizeint; // match TInitManagedField/TManagedField in FPC typinfo.pp
{$else}
Offset: PtrUInt;
{$endif FPC}
{$ifdef ISDELPHI2010}
Flags: Byte;
NameLen: byte; // = Name[0] = length(Name)
{$ENDIF}
end;
PEnhancedFieldInfo = ^TEnhancedFieldInfo;
{$endif}
TTypeInfo =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
kind: TTypeKind;
NameLen: byte;
case TTypeKind of
tkUnknown: (
NameFirst: AnsiChar;
);
tkDynArray: (
{$ifdef FPC}
elSize: SizeUInt; // and $7FFFFFFF = item/record size
elType2: PTypeInfoStored;
varType: LongInt;
elType: PTypeInfoStored;
//DynUnitName: ShortStringBase;
{$else}
// storage byte count for this field
elSize: Longint;
// nil for unmanaged field
elType: PTypeInfoStored;
// OleAuto compatible type
varType: Integer;
// also unmanaged field
elType2: PTypeInfoStored;
{$endif FPC}
);
tkArray: (
{$ifdef FPC}
// warning: in VER2_6, this is the element size, not full array size
arraySize: SizeInt;
// product of lengths of all dimensions
elCount: SizeInt;
{$else}
arraySize: Integer;
// product of lengths of all dimensions
elCount: Integer;
{$endif FPC}
arrayType: PTypeInfoStored;
dimCount: Byte;
dims: array[0..255 {DimCount-1}] of PTypeInfoStored;
);
{$ifdef FPC}
tkRecord, tkObject:(
{$ifdef FPC_NEWRTTI}
RecInitInfo: Pointer; // call GetManagedFields() to use FPC's TypInfo.pp
recSize: longint;
{$else}
ManagedCount: longint;
ManagedFields: array[0..0] of TFieldInfo;
// note: FPC for 3.0.x and previous generates RTTI for unmanaged fields (as in TEnhancedFieldInfo)
{$endif FPC_NEWRTTI}
{$else}
tkRecord: (
recSize: cardinal;
ManagedCount: integer;
ManagedFields: array[0..0] of TFieldInfo;
{$ifdef ISDELPHI2010} // enhanced RTTI containing info about all fields
NumOps: Byte;
//RecOps: array[0..0] of Pointer;
AllCount: Integer; // !!!! may need $RTTI EXPLICIT FIELDS([vcPublic])
AllFields: array[0..0] of TEnhancedFieldInfo;
{$endif ISDELPHI2010}
{$endif FPC}
);
tkEnumeration: (
EnumType: TOrdType;
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
EnumDummy: DWORD; // needed on ARM for correct alignment
{$endif}
{$ifdef FPC_ENUMHASINNER} inner:
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} packed {$endif} record
{$endif FPC_ENUMHASINNER}
MinValue: longint;
MaxValue: longint;
EnumBaseType: PTypeInfoStored; // BaseTypeRef in FPC TypInfo.pp
{$ifdef FPC_ENUMHASINNER} end; {$endif FPC_ENUMHASINNER}
NameList: string[255];
);
tkInteger: (
IntegerType: TOrdType;
);
tkInt64: (
MinInt64Value, MaxInt64Value: Int64;
);
tkSet: (
SetType: TOrdType;
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
SetDummy: DWORD; // needed on ARM for correct alignment
{$endif}
{$ifdef FPC}
{$ifndef VER3_0}
SetSize: SizeInt;
{$endif VER3_0}
{$endif FPC}
SetBaseType: PTypeInfoStored; // CompTypeRef in FPC TypInfo.pp
);
tkFloat: (
FloatType: TFloatType;
);
tkClass: (
ClassType: TClass;
ParentInfo: PTypeInfoStored; // ParentInfoRef in FPC TypInfo.pp
PropCount: SmallInt;
UnitNameLen: byte;
);
end;
{$ifdef FPC}
{$push}
{$PACKRECORDS 1}
{$endif}
TPropInfo = packed record
PropType: PTypeInfoStored;
GetProc: PtrInt;
SetProc: PtrInt;
StoredProc: PtrInt;
Index: Integer;
Default: Longint;
NameIndex: SmallInt;
{$ifdef FPC}
PropProcs : Byte;
{$ifdef FPC_PROVIDE_ATTR_TABLE}
/// property attributes, introduced since FPC SVN 42356-42411 (2019/07)
AttributeTable: Pointer;
{$endif FPC_PROVIDE_ATTR_TABLE}
{$endif}
NameLen: byte;
end;
PPropInfo = ^TPropInfo;
{$ifdef FPC}
{$pop}
{$endif}
{$ifdef HASDIRECTTYPEINFO}
type
Deref = PTypeInfo;
{$else}
function Deref(Info: PTypeInfoStored): PTypeInfo; // for Delphi and newer FPC
{$ifdef HASINLINE} inline;
begin
result := pointer(Info);
if Info<>nil then
result := Info^;
end;
{$else}
asm // Delphi is so bad at compiling above code...
or eax, eax
jz @z
mov eax, [eax]
ret
@z: db $f3 // rep ret
end;
{$endif HASINLINE}
{$endif HASDIRECTTYPEINFO}
const
/// codePage offset = string header size
// - used to calc the beginning of memory allocation of a string
STRRECSIZE = SizeOf(TStrRec);
{$ifdef HASCODEPAGE}
function FastNewString(len: PtrInt; cp: cardinal): PAnsiChar; inline;
begin
if len>0 then begin
{$ifdef FPC_X64MM}result := _Getmem({$else}GetMem(result,{$endif}len+(STRRECSIZE+4));
PStrRec(result)^.codePage := cp;
PStrRec(result)^.elemSize := 1;
PStrRec(result)^.refCnt := 1;
PStrRec(result)^.length := len;
PCardinal(result+len+STRRECSIZE)^ := 0; // ensure ends with four #0
inc(PStrRec(result));
end else
result := nil;
end;
{$endif HASCODEPAGE}
{$ifdef FPC_X64}
procedure fpc_ansistr_decr_ref; external name 'FPC_ANSISTR_DECR_REF';
procedure fpc_ansistr_incr_ref; external name 'FPC_ANSISTR_INCR_REF';
procedure fpc_ansistr_assign; external name 'FPC_ANSISTR_ASSIGN';
procedure fpc_ansistr_setlength; external name 'FPC_ANSISTR_SETLENGTH';
procedure fpc_ansistr_compare; external name 'FPC_ANSISTR_COMPARE';
procedure fpc_ansistr_compare_equal; external name 'FPC_ANSISTR_COMPARE_EQUAL';
procedure fpc_unicodestr_decr_ref; external name 'FPC_UNICODESTR_DECR_REF';
procedure fpc_unicodestr_incr_ref; external name 'FPC_UNICODESTR_INCR_REF';
procedure fpc_unicodestr_assign; external name 'FPC_UNICODESTR_ASSIGN';
procedure fpc_dynarray_incr_ref; external name 'FPC_DYNARRAY_INCR_REF';
procedure fpc_dynarray_decr_ref; external name 'FPC_DYNARRAY_DECR_REF';
procedure fpc_dynarray_clear; external name 'FPC_DYNARRAY_CLEAR';
{$ifdef FPC_X64MM}
procedure fpc_getmem; external name 'FPC_GETMEM';
procedure fpc_freemem; external name 'FPC_FREEMEM';
{$else}
procedure _Getmem; external name 'FPC_GETMEM';
procedure _Freemem; external name 'FPC_FREEMEM';
{$endif FPC_X64MM}
procedure PatchJmp(old, new: PByteArray; size: PtrInt; jmp: PtrUInt=0);
var
rel: PCardinal;
begin
PatchCode(old, new, size, nil, {unprotected=}true);
if jmp = 0 then
jmp := PtrUInt(@_Freemem);
repeat // search and fix "jmp rel fpc_freemem/_dynarray_decr_ref_free"
dec(size);
if size = 0 then
exit;
rel := @old[size + 1];
until (old[size] = $e9) and
(rel^ = cardinal(jmp - PtrUInt(@new[size]) - 5));
rel^ := jmp - PtrUInt(rel) - 4;
end;
procedure _ansistr_decr_ref(var p: Pointer); nostackframe; assembler;
asm
mov rax, qword ptr[p]
xor edx, edx
test rax, rax
jz @z
mov qword ptr[p], rdx
mov p, rax
{$ifdef STRCNT32}
cmp dword ptr[rax - _STRREFCNT], rdx
jl @z
lock dec dword ptr[rax - _STRREFCNT]
{$else}
cmp qword ptr[rax - _STRREFCNT], rdx
jl @z
lock dec qword ptr[rax - _STRREFCNT]
{$endif STRCNT32}
jbe @free
@z: ret
@free: sub p, STRRECSIZE
jmp _Freemem
end;
procedure _ansistr_incr_ref(p: pointer); nostackframe; assembler;
asm
test p, p
jz @z
{$ifdef STRCNT32}
cmp dword ptr[p - _STRREFCNT], 0
jl @z
lock inc dword ptr[p - _STRREFCNT]
{$else}
cmp qword ptr[p - _STRREFCNT], 0
jl @z
lock inc qword ptr[p - _STRREFCNT]
{$endif STRCNT32}
@z:
end;
procedure _ansistr_assign(var d: pointer; s: pointer); nostackframe; assembler;
asm
mov rax, qword ptr[d]
cmp rax, s
jz @eq
test s, s
jz @ns
{$ifdef STRCNT32}
cmp dword ptr[s - _STRREFCNT], 0
jl @ns
lock inc dword ptr[s - _STRREFCNT]
@ns: mov qword ptr[d], s
test rax, rax
jnz @z
@eq: ret
@z: mov d, rax
cmp dword ptr[rax - _STRREFCNT], 0
jl @n
lock dec dword ptr[rax - _STRREFCNT]
{$else}
cmp qword ptr[s - _STRREFCNT], 0
jl @ns
lock inc qword ptr[s - _STRREFCNT]
@ns: mov qword ptr[d], s
test rax, rax
jnz @z
@eq: ret
@z: mov d, rax
cmp qword ptr[rax - _STRREFCNT], 0
jl @n
lock dec qword ptr[rax - _STRREFCNT]
{$endif STRCNT32}
ja @n
@free: sub d, STRRECSIZE
jmp _Freemem
@n:
end;
{ note: fpc_ansistr_compare/_equal do check the codepage and make a UTF-8
conversion if necessary, whereas Delphi _LStrCmp/_LStrEqual don't;
involving codepage is safer, but paranoid, and 1. is (much) slower, and
2. is not Delphi compatible -> we rather follow the Delphi/Lazy's way }
function _ansistr_compare(s1, s2: pointer): SizeInt; nostackframe; assembler;
asm
xor eax, eax
cmp s1, s2
je @0
test s1, s2
jz @maybe0
@first: mov al, byte ptr[s1] // we can check the first char (for quicksort)
sub al, byte ptr[s2]
jne @ne
mov r8, qword ptr[s1 - _STRLEN]
mov r11, r8
sub r8, qword ptr[s2 - _STRLEN] // r8 = length(s1)-length(s2)
adc rax, -1
and rax, r8 // rax = -min(length(s1),length(s2))
sub rax, r11
sub s1, rax
sub s2, rax
align 8
@s: mov r10, qword ptr[s1 + rax] // compare by 8 bytes (may include len)
xor r10, qword ptr[s2 + rax]
jnz @d
add rax, 8
js @s
@e: mov rax, r8 // all equal -> return difflen
@0: ret
@ne: movsx rax, al
ret
@d: bsf r10, r10 // compute s1^-s2^
shr r10, 3
add rax, r10
jns @e
movzx edx, byte ptr[s2 + rax]
movzx eax, byte ptr[s1 + rax]
sub rax, rdx
ret
@maybe0:test s2, s2
jz @1
test s1, s1
jnz @first
dec rax
ret
@1: inc eax
end;
function _ansistr_compare_equal(s1, s2: pointer): SizeInt; nostackframe; assembler;
asm
xor eax, eax
cmp s1, s2
je @q
test s1, s2
jz @maybe0
@ok: mov rax, qword ptr[s1 - _STRLEN] // len must match
cmp rax, qword ptr[s2 - _STRLEN]
jne @q
lea s1, qword ptr[s1 + rax - 8]
lea s2, qword ptr[s2 + rax - 8]
neg rax
mov r8, qword ptr[s1] // compare last 8 bytes (may include len)
cmp r8, qword ptr[s2]
jne @q
align 16
@s: add rax, 8 // compare remaining 8 bytes per iteration
jns @0
mov r8, qword ptr[s1 + rax]
cmp r8, qword ptr[s2 + rax]
je @s
mov eax, 1
ret
@0: xor eax, eax
@q: ret
@maybe0:test s2, s2
jz @1
test s1, s1
jnz @ok
@1: inc eax // not zero is enough
end;
procedure _dynarray_incr_ref(p: pointer); nostackframe; assembler;
asm
test p, p
jz @z
cmp qword ptr[p - _DAREFCNT], 0
jle @z
lock inc qword ptr[p - _DAREFCNT]
@z:
end;
procedure _dynarray_decr_ref_free(p: PDynArrayRec; info: pointer); forward;
procedure _dynarray_decr_ref(var p: Pointer; info: pointer); nostackframe; assembler;
asm
mov rax, qword ptr[p]
test rax, rax
jz @z
mov qword ptr[p], 0
mov p, rax
sub p, SizeOf(TDynArrayRec)
cmp qword ptr[rax - _DAREFCNT], 0
jle @z
lock dec qword ptr[p]
jbe @free
@z: ret
@free: jmp _dynarray_decr_ref_free
end;
procedure FastAssignNew(var d; s: pointer); nostackframe; assembler;
asm
mov rax, qword ptr[d]
mov qword ptr[d], s
test rax, rax
jz @z
mov d, rax
{$ifdef STRCNT32}
cmp dword ptr[rax - _STRREFCNT], 0
jl @z
lock dec dword ptr[rax - _STRREFCNT]
{$else}
cmp qword ptr[rax - _STRREFCNT], 0
jl @z
lock dec qword ptr[rax - _STRREFCNT]
{$endif STRCNT32}
jbe @free
@z: ret
@free: sub d, STRRECSIZE
jmp _Freemem
end;
{$ifdef FPC_HAS_CPSTRING}
{$ifdef FPC_X64MM}
procedure _ansistr_setlength_new(var s: RawByteString; len: PtrInt; cp: cardinal);
var p, new: PAnsiChar;
l: PtrInt;
begin
if cp<=CP_OEMCP then begin // TranslatePlaceholderCP logic
cp := DefaultSystemCodePage;
if cp=0 then
cp := CP_NONE;
end;
new := FastNewString(len,cp);
p := pointer(s);
if p<>nil then begin
l := PStrLen(p-_STRLEN)^+1;
if l>len then
l := len;
MoveFast(p^,new^,l);
end;
FastAssignNew(s,new);
end;
procedure _ansistr_setlength(var s: RawByteString; len: PtrInt; cp: cardinal);
nostackframe; assembler;
asm
mov rax, qword ptr[s]
test len, len
jle _ansistr_decr_ref
test rax, rax
jz _ansistr_setlength_new
{$ifdef STRCNT32}
cmp dword ptr[rax - _STRREFCNT], 1
{$else}
cmp qword ptr[rax - _STRREFCNT], 1
{$endif STRCNT32}
jne _ansistr_setlength_new
push len
push s
sub qword ptr[s], STRRECSIZE
add len, STRRECSIZE + 1
call _reallocmem // rely on MM in-place detection
pop s
pop len
add qword ptr[s], STRRECSIZE
mov qword ptr[rax].TStrRec.length, len
mov byte ptr[rax + len + STRRECSIZE], 0
end;
{$endif FPC_X64MM}
// _ansistr_concat_convert* optimized for systemcodepage=CP_UTF8
function ToTempUTF8(var temp: TSynTempBuffer; p: pointer; len, cp: cardinal): pointer;
begin
if (len=0) or (cp=CP_UTF8) or (cp>=CP_SQLRAWBLOB) or IsAnsiCompatible(p,len) then begin
temp.buf := nil;
temp.len := len;
result := p;
end else begin
temp.Init(len*3);
p := TSynAnsiConvert.Engine(cp).AnsiBufferToUTF8(temp.buf,p,len);
temp.len := PAnsiChar(p)-PAnsiChar(temp.buf);
result := temp.buf;
end;
end;
procedure _ansistr_concat_convert(var dest: RawByteString; const s1,s2: RawByteString;
cp,cp1,cp2: cardinal);
var t1, t2, t: TSynTempBuffer; // avoid most memory allocation
p1, p2, p: PAnsiChar;
eng: TSynAnsiConvert;
begin
p1 := ToTempUTF8(t1,pointer(s1),length(s1),cp1);
p2 := ToTempUTF8(t2,pointer(s2),length(s2),cp2);
if (cp=CP_UTF8) or (cp>=CP_SQLRAWBLOB) or ((t1.buf=nil) and (t2.buf=nil)) then begin
p := FastNewString(t1.len+t2.len,cp);
MoveFast(p1^,p[0],t1.len);
MoveFast(p2^,p[t1.len],t2.len);
FastAssignNew(dest,p);
end else begin
eng := TSynAnsiConvert.Engine(cp);
t.Init((t1.len+t2.len) shl eng.fAnsiCharShift);
p := eng.UTF8BufferToAnsi(eng.UTF8BufferToAnsi(t.buf,p1,t1.len),p2,t2.len);
FastSetStringCP(dest,t.buf,p-t.buf,cp);
t.Done;
end;
t2.Done;
t1.Done;
end;
function _lstrlen(const s: RawByteString): TStrLen; inline;
begin
result := PStrLen(PtrUInt(s)-_STRLEN)^;
end;
function _lstrcp(const s: RawByteString; cp: integer): integer; inline;
begin
result := cp;
if s<>'' then begin
result := PStrRec(PtrUInt(s)-STRRECSIZE)^.codePage;
if result<=CP_OEMCP then
result := CP_UTF8;
end;
end;
procedure _ansistr_concat_utf8(var dest: RawByteString;
const s1,s2: RawByteString; cp: cardinal);
var cp1, cp2: cardinal;
new: PAnsiChar;
l1: PtrInt;
begin
if cp<=CP_OEMCP then // TranslatePlaceholderCP logic
cp := CP_UTF8;
cp1 := _lstrcp(s1,cp);
cp2 := _lstrcp(s2,cp1);
if (cp1=cp2) and ((cp>=CP_SQLRAWBLOB) or (cp=cp1)) then
cp := cp1 else
if ((cp1<>cp) and (cp1<CP_SQLRAWBLOB)) or
((cp2<>cp) and (cp2<CP_SQLRAWBLOB)) then begin
_ansistr_concat_convert(dest,s1,s2,cp,cp1,cp2);
exit;
end;
if s1='' then
dest := s2 else
if s2='' then
dest := s1 else begin
l1 := _lstrlen(s1);
if pointer(s1)=pointer(dest) then begin // dest := dest+s2 -> self-resize dest
SetLength(dest,l1+_lstrlen(s2));
PStrRec(PtrUInt(dest)-STRRECSIZE)^.codepage := cp;
MoveFast(pointer(s2)^,PByteArray(dest)[l1],_lstrlen(s2));
end else begin
new := FastNewString(l1+_lstrlen(s2),cp);
MoveFast(pointer(s1)^,new[0],l1);
MoveFast(pointer(s2)^,new[l1],_lstrlen(s2));
FastAssignNew(dest,new);
end;
end;
end;
procedure _ansistr_concat_multi_convert(var dest: RawByteString;
s: PRawByteString; scount, cp: cardinal);
var t: TTextWriter;
u: RawUTF8;
tmp: TTextWriterStackBuffer;
begin
t := TTextWriter.CreateOwnedStream(tmp);
try
repeat
if s^<>'' then
t.AddAnyAnsiBuffer(pointer(s^),_lstrlen(s^),twNone,_lstrcp(s^,cp));
inc(s);
dec(scount);
until scount=0;
t.SetText(u);
finally
t.Free;
end;
if (cp=CP_UTF8) or (cp>=CP_SQLRAWBLOB) then
dest := u else
TSynAnsiConvert.Engine(cp).UTF8BufferToAnsi(pointer(u),length(u),dest);
end;
procedure _ansistr_concat_multi_utf8(var dest: RawByteString;
const s: array of RawByteString; cp: cardinal);
var first,len,i,l: integer; // should NOT be PtrInt/SizeInt to avoid FPC bug with high(s) :(
cpf,cpi: cardinal;
p: pointer;
new: PAnsiChar;
begin
if cp<=CP_OEMCP then
cp := CP_UTF8;
first := 0;
repeat
if first>high(s) then begin
_ansistr_decr_ref(pointer(dest));
exit;
end;
p := pointer(s[first]);
if p<>nil then
break;
inc(first);
until false;
len := _lstrlen(RawByteString(p));
cpf := _lstrcp(RawByteString(p),cp);
if (cpf<>cp) and (cpf<CP_SQLRAWBLOB) then
cpf := 0 else
for i := first+1 to high(s) do begin
p := pointer(s[i]);
if p<>nil then begin
inc(len,_lstrlen(RawByteString(p)));
cpi := PStrRec(PtrUInt(p)-STRRECSIZE)^.codePage;
if cpi<=CP_OEMCP then
cpi := CP_UTF8;
if (cpi<>cpf) and (cpi<CP_SQLRAWBLOB) then begin
cpf := 0;
break;
end;
end;
end;
if cpf=0 then
_ansistr_concat_multi_convert(dest,@s[0],length(s),cp) else begin
p := pointer(s[first]);
l := _lstrlen(RawByteString(p));
if p=pointer(dest) then begin // dest := dest+s... -> self-resize
SetLength(dest,len);
new := pointer(dest);
PStrRec(PtrUInt(dest)-STRRECSIZE)^.codepage := cp;
cp := 0;
end else begin
new := FastNewString(len,cp);
MoveFast(p^,new[0],l);
end;
for i := first+1 to high(s) do begin
p := pointer(s[i]);
if p<>nil then begin
MoveFast(p^,new[l],_lstrlen(RawByteString(p)));
inc(l,_lstrlen(RawByteString(p)));
end;
end;
if cp<>0 then
FastAssignNew(dest,new);
end;
end;
procedure _fpc_ansistr_concat(var a: RawUTF8);
begin
a := a+a; // to generate "call fpc_ansistr_concat" opcode
end;
procedure _fpc_ansistr_concat_multi(var a: RawUTF8);
begin
a := a+a+a; // to generate "call fpc_ansistr_concat_multi" opcode
end;
procedure RedirectRtl(dummy, dest: PByteArray);
begin
repeat
if (dummy[0]=$b9) and (PCardinal(@dummy[1])^=CP_UTF8) then
case dummy[5] of
$e8: begin
// found "mov ecx,65001; call fpc_ansistr_concat" opcodes
RedirectCode(@dummy[PInteger(@dummy[6])^+10],dest);
exit;
end;
$ba: if (PCardinal(@dummy[6])^=2) and (dummy[10]=$e8) then
begin
// found "mov ecx,65001; mov edx,2; call fpc_ansistr_concat_multi"
RedirectCode(@dummy[PInteger(@dummy[11])^+15],dest);
exit;
end;
end;
inc(PByte(dummy));
until PInt64(dummy)^=0;
end;
{$endif FPC_HAS_CPSTRING}
{$else}
procedure FastAssignNew(var d; s: pointer); {$ifdef HASINLINE} inline; {$endif}
var
sr: PStrRec; // local copy to use register
begin
sr := Pointer(d);
Pointer(d) := s;
if sr = nil then
exit;
dec(sr);
if (sr^.refcnt >= 0) and StrCntDecFree(sr^.refcnt) then
FreeMem(sr);
end;
{$endif FPC_X64}
{$ifdef HASCODEPAGE}
procedure FastSetStringCP(var s; p: pointer; len, codepage: PtrInt);
var r: pointer;
begin
r := FastNewString(len,codepage);
if p<>nil then
MoveFast(p^,r^,len);
FastAssignNew(s,r);
end;
procedure FastSetString(var s: RawUTF8; p: pointer; len: PtrInt);
var r: pointer;
begin
r := FastNewString(len,CP_UTF8);
if p<>nil then
MoveFast(p^,r^,len);
FastAssignNew(s,r);
end;
{$else not HASCODEPAGE}
procedure FastSetStringCP(var s; p: pointer; len, codepage: PtrInt);
begin
SetString(RawByteString(s),PAnsiChar(p),len);
end;
procedure FastSetString(var s: RawUTF8; p: pointer; len: PtrInt);
begin
SetString(RawByteString(s),PAnsiChar(p),len);
end;
{$endif HASCODEPAGE}
procedure GetMemAligned(var s: RawByteString; p: pointer; len: PtrInt;
out aligned: pointer);
begin
SetString(s,nil,len+16);
aligned := pointer(s);
inc(PByte(aligned),PtrUInt(aligned) and 15);
if p<>nil then
MoveFast(p^,aligned^,len);
end;
function ToText(k: TTypeKind): PShortString;
begin
result := GetEnumName(TypeInfo(TTypeKind),ord(k));
end;
function ToText(k: TDynArrayKind): PShortString;
begin
result := GetEnumName(TypeInfo(TDynArrayKind),ord(k));
end;
function UniqueRawUTF8(var UTF8: RawUTF8): pointer;
begin
{$ifdef FPC}
UniqueString(UTF8); // @UTF8[1] won't call UniqueString() under FPC :(
{$endif}
result := @UTF8[1];
end;
procedure UniqueRawUTF8ZeroToTilde(var UTF8: RawUTF8; MaxSize: integer);
var i: integer;
begin
i := length(UTF8);
if i>MaxSize then
PByteArray(UTF8)[MaxSize] := 0 else
MaxSize := i;
for i := 0 to MaxSize-1 do
if PByteArray(UTF8)[i]=0 then
PByteArray(UTF8)[i] := ord('~');
end;
{$ifdef FPC}
function TDynArrayRec.GetLength: sizeint;
begin
result := high+1;
end;
procedure TDynArrayRec.SetLength(len: sizeint);
begin
high := len-1;
end;
{$endif FPC}
function DynArrayLength(Value: Pointer): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
begin
result := PtrInt(Value);
if result<>0 then
result := PDALen(result-_DALEN)^{$ifdef FPC}+1{$endif};
end;
{$ifdef HASALIGNTYPEDATA}
function FPCTypeInfoOverName(P: pointer): pointer; inline;
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} {$ifdef CPUARM3264}
const diff=SizeOf(QWord);// always on these two CPU's
{$else} var diff: PtrUInt; {$endif} {$endif}
begin
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
{$ifndef CPUARM3264}
diff := PtrUInt(@PTypeInfo(P)^.NameFirst)-PtrUInt(@PTypeInfo(P)^.Kind);
{$endif}
result := AlignTypeData(P+2+PByte(P+1)^);
dec(PByte(result),diff);
{$else}
result := AlignTypeData(P+PByte(P+1)^);
{$endif}
end;
{$endif HASALIGNTYPEDATA}
function GetTypeInfo(aTypeInfo: pointer; aExpectedKind: TTypeKind): PTypeInfo; overload;
{$ifdef HASINLINE} inline;
begin
result := aTypeInfo;
if result<>nil then
if result^.Kind=aExpectedKind then
{$ifdef HASALIGNTYPEDATA}
result := FPCTypeInfoOverName(result)
{$else}
inc(PByte(result),result^.NameLen)
{$endif}
else
result := nil;
end;
{$else}
asm
test eax, eax
jz @n
movzx ecx, byte ptr[eax + TTypeInfo.NameLen]
cmp dl, [eax]
jne @n
add eax, ecx
ret
@n: xor eax, eax
end;
{$endif HASINLINE}
function GetTypeInfo(aTypeInfo: pointer; const aExpectedKind: TTypeKinds): PTypeInfo; overload;
{$ifdef HASINLINE} inline;
begin
result := aTypeInfo;
if result<>nil then
if result^.Kind in aExpectedKind then
{$ifdef HASALIGNTYPEDATA}
result := FPCTypeInfoOverName(result)
{$else}
inc(PByte(result),result^.NameLen)
{$endif}
else
result := nil;
end;
{$else}
asm // eax=aTypeInfo edx=aExpectedKind
test eax, eax
jz @n
movzx ecx, byte ptr[eax]
bt edx, ecx
movzx ecx, byte ptr[eax + TTypeInfo.NameLen]
jnb @n
add eax, ecx
ret
@n: xor eax, eax
end;
{$endif HASINLINE}
function GetTypeInfo(aTypeInfo: pointer): PTypeInfo; overload;
{$ifdef HASINLINE} inline;
begin
{$ifdef HASALIGNTYPEDATA}
result := FPCTypeInfoOverName(aTypeInfo);
{$else}
result := @PAnsiChar(aTypeInfo)[PTypeInfo(aTypeInfo)^.NameLen];
{$endif}
end;
{$else}
asm
movzx ecx, byte ptr[eax + TTypeInfo.NameLen]
add eax, ecx
end;
{$endif HASINLINE}
function DynArrayTypeInfoToRecordInfo(aDynArrayTypeInfo: pointer;
aDataSize: PInteger): pointer;
var info: PTypeInfo;
begin
result := nil;
info := GetTypeInfo(aDynArrayTypeInfo,tkDynArray);
if info=nil then
exit;
if info^.elType<>nil then
result := Deref(info^.elType);
if aDataSize<>nil then
aDataSize^ := info^.elSize {$ifdef FPC}and $7FFFFFFF{$endif};
end;
procedure TypeInfoToName(aTypeInfo: pointer; var result: RawUTF8;
const default: RawUTF8);
begin
if aTypeInfo<>nil then
FastSetString(result,PAnsiChar(@PTypeInfo(aTypeInfo)^.NameLen)+1,
PTypeInfo(aTypeInfo)^.NameLen) else
result := default;
end;
function TypeInfoToShortString(aTypeInfo: pointer): PShortString;
begin
if aTypeInfo<>nil then
result := @PTypeInfo(aTypeInfo)^.NameLen else
result := nil;
end;
procedure TypeInfoToQualifiedName(aTypeInfo: pointer; var result: RawUTF8;
const default: RawUTF8);
var unitname: RawUTF8;
begin
if aTypeInfo<>nil then begin
FastSetString(result,PAnsiChar(@PTypeInfo(aTypeInfo)^.NameLen)+1,
PTypeInfo(aTypeInfo)^.NameLen);
if PTypeInfo(aTypeInfo)^.Kind=tkClass then begin
with GetTypeInfo(aTypeInfo)^ do
FastSetString(unitname,PAnsiChar(@UnitNameLen)+1,UnitNameLen);
result := unitname+'.'+result;
end;
end else result := default;
end;
function TypeInfoToName(aTypeInfo: pointer): RawUTF8;
begin
TypeInfoToName(aTypeInfo,Result,'');
end;
function RecordTypeInfoSize(aRecordTypeInfo: pointer): integer;
var info: PTypeInfo;
begin
info := GetTypeInfo(aRecordTypeInfo,tkRecordKinds);
if info=nil then
result := 0 else
result := info^.recSize;
end;
function GetEnumInfo(aTypeInfo: pointer; out MaxValue: Integer): PShortString;
{$ifdef HASINLINE} inline;
var info: PTypeInfo;
base: PTypeInfoStored;
begin
if (aTypeInfo<>nil) and (PTypeKind(aTypeInfo)^=tkEnumeration) then begin
info := GetTypeInfo(aTypeInfo);
base := info^.{$ifdef FPC_ENUMHASINNER}inner.{$endif}EnumBaseType;
{$ifdef FPC} // no redirection if aTypeInfo is already the base type
if (base<>nil) and (base{$ifndef HASDIRECTTYPEINFO}^{$endif}<>aTypeInfo) then
{$endif}
info := GetTypeInfo(base{$ifndef HASDIRECTTYPEINFO}^{$endif});
MaxValue := info^.{$ifdef FPC_ENUMHASINNER}inner.{$endif}MaxValue;
result := @info^.NameList;
end else
result := nil;
end;
{$else}
asm // eax=aTypeInfo edx=@MaxValue
test eax, eax
jz @n
cmp byte ptr[eax], tkEnumeration
jnz @n
movzx ecx, byte ptr[eax + TTypeInfo.NameLen]
mov eax, [eax + ecx + TTypeInfo.EnumBaseType]
mov eax, [eax]
movzx ecx, byte ptr[eax + TTypeInfo.NameLen]
add eax, ecx
mov ecx, [eax + TTypeInfo.MaxValue]
mov [edx], ecx
lea eax, [eax + TTypeInfo.NameList]
ret
@n: xor eax, eax
end;
{$endif HASINLINE}
function GetSetBaseEnum(aTypeInfo: pointer): pointer;
begin
result := GetTypeInfo(aTypeInfo,tkSet);
if result<>nil then
result := Deref(PTypeInfo(result)^.SetBaseType);
end;
function GetSetInfo(aTypeInfo: pointer; out MaxValue: Integer;
out Names: PShortString): boolean; {$ifdef HASINLINE}inline;{$endif}
var info: PTypeInfo;
begin
info := GetTypeInfo(aTypeInfo,tkSet);
if info<>nil then begin
Names := GetEnumInfo(Deref(info^.SetBaseType),MaxValue);
result := Names<>nil;
end else
result := false;
end;
const
NULL_LOW = ord('n')+ord('u')shl 8+ord('l')shl 16+ord('l')shl 24;
FALSE_LOW = ord('f')+ord('a')shl 8+ord('l')shl 16+ord('s')shl 24;
FALSE_LOW2 = ord('a')+ord('l')shl 8+ord('s')shl 16+ord('e')shl 24;
TRUE_LOW = ord('t')+ord('r')shl 8+ord('u')shl 16+ord('e')shl 24;
NULL_SHORTSTRING: string[1] = '';
procedure GetEnumNames(aTypeInfo: pointer; aDest: PPShortString);
var MaxValue, i: integer;
res: PShortString;
begin
res := GetEnumInfo(aTypeInfo,MaxValue);
if res<>nil then
for i := 0 to MaxValue do begin
aDest^ := res;
inc(PByte(res),PByte(res)^+1); // next
inc(aDest);
end;
end;
procedure GetEnumTrimmedNames(aTypeInfo: pointer; aDest: PRawUTF8);
var MaxValue, i: integer;
res: PShortString;
begin
res := GetEnumInfo(aTypeInfo,MaxValue);
if res<>nil then
for i := 0 to MaxValue do begin
aDest^ := TrimLeftLowerCaseShort(res);
inc(PByte(res),PByte(res)^+1); // next
inc(aDest);
end;
end;
function GetEnumTrimmedNames(aTypeInfo: pointer): TRawUTF8DynArray;
var MaxValue, i: integer;
res: PShortString;
begin
Finalize(result);
res := GetEnumInfo(aTypeInfo,MaxValue);
if res=nil then
exit;
SetLength(result,MaxValue+1);
for i := 0 to MaxValue do begin
result[i] := TrimLeftLowerCaseShort(res);
inc(PByte(res),PByte(res)^+1); // next
end;
end;
procedure GetCaptionFromTrimmed(PS: PShortString; var result: string);
var tmp: array[byte] of AnsiChar;
L: integer;
begin
L := ord(PS^[0]);
inc(PByte(PS));
while (L>0) and (PS^[0] in ['a'..'z']) do begin inc(PByte(PS)); dec(L); end;
tmp[L] := #0; // as expected by GetCaptionFromPCharLen/UnCamelCase
if L>0 then
MoveSmall(PS,@tmp,L);
GetCaptionFromPCharLen(tmp,result);
end;
procedure GetEnumCaptions(aTypeInfo: pointer; aDest: PString);
var MaxValue, i: integer;
res: PShortString;
begin
res := GetEnumInfo(aTypeInfo,MaxValue);
if res<>nil then
for i := 0 to MaxValue do begin
GetCaptionFromTrimmed(res,aDest^);
inc(PByte(res),PByte(res)^+1); // next
inc(aDest);
end;
end;
function GetEnumName(aTypeInfo: pointer; aIndex: integer): PShortString;
{$ifdef HASINLINENOTX86}
var MaxValue: integer;
begin
result := GetEnumInfo(aTypeInfo,MaxValue);
if (result<>nil) and (cardinal(aIndex)<=cardinal(MaxValue)) then begin
if aIndex>0 then
repeat
inc(PByte(result),PByte(result)^+1); // next
dec(aIndex);
if aIndex=0 then
break;
inc(PByte(result),PByte(result)^+1); // loop unrolled twice
dec(aIndex);
until aIndex=0;
end else
result := @NULL_SHORTSTRING;
end;
{$else}
asm // eax=aTypeInfo edx=aIndex
test eax, eax
jz @0
cmp byte ptr[eax], tkEnumeration
jnz @0
movzx ecx, byte ptr[eax + TTypeInfo.NameLen]
mov eax, [eax + ecx + TTypeInfo.EnumBaseType]
mov eax, [eax]
movzx ecx, byte ptr[eax + TTypeInfo.NameLen]
cmp edx, [eax + ecx + TTypeInfo.MaxValue]
ja @0
lea eax, [eax + ecx + TTypeInfo.NameList]
test edx, edx
jz @z
push edx
shr edx, 2 // fast by-four scanning
jz @1
@4: dec edx
movzx ecx, byte ptr[eax]
lea eax, [eax + ecx + 1]
movzx ecx, byte ptr[eax]
lea eax, [eax + ecx + 1]
movzx ecx, byte ptr[eax]
lea eax, [eax + ecx + 1]
movzx ecx, byte ptr[eax]
lea eax, [eax + ecx + 1]
jnz @4
pop edx
and edx, 3
jnz @s
ret
@1: pop edx
@s: movzx ecx, byte ptr[eax]
dec edx
lea eax, [eax + ecx + 1] // next
jnz @s
ret
@z: rep ret
@0: lea eax, NULL_SHORTSTRING
end;
{$endif HASINLINENOTX86}
{$ifdef PUREPASCAL} // for proper inlining
function IdemPropNameUSameLen(P1,P2: PUTF8Char; P1P2Len: PtrInt): boolean;
label zero;
begin
P1P2Len := PtrInt(@PAnsiChar(P1)[P1P2Len-SizeOf(cardinal)]);
if P1P2Len>=PtrInt(PtrUInt(P1)) then
repeat // case-insensitive compare 4 bytes per loop
if (PCardinal(P1)^ xor PCardinal(P2)^) and $dfdfdfdf<>0 then
goto zero;
inc(P1,SizeOf(cardinal));
inc(P2,SizeOf(cardinal));
until P1P2Len<PtrInt(PtrUInt(P1));
inc(P1P2Len,SizeOf(cardinal));
dec(PtrUInt(P2),PtrUInt(P1));
if PtrInt(PtrUInt(P1))<P1P2Len then
repeat
if (ord(P1^) xor ord(P2[PtrUInt(P1)])) and $df<>0 then
goto zero;
inc(P1);
until PtrInt(PtrUInt(P1))>=P1P2Len;
result := true;
exit;
zero:
result := false;
end;
{$endif PUREPASCAL}
function IdemPropNameUSmallNotVoid(P1,P2,P1P2Len: PtrInt): boolean;
{$ifdef HASINLINE}inline;{$endif}
label zero;
begin
inc(P1P2Len,P1);
dec(P2,P1);
repeat
if (PByte(P1)^ xor ord(PAnsiChar(P1)[P2])) and $df<>0 then
goto zero;
inc(P1);
until P1>=P1P2Len;
result := true;
exit;
zero:
result := false;
end;
function FindShortStringListExact(List: PShortString; MaxValue: integer;
aValue: PUTF8Char; aValueLen: PtrInt): integer;
var PLen: PtrInt;
begin
if aValueLen<>0 then
for result := 0 to MaxValue do begin
PLen := PByte(List)^;
if (PLen=aValuelen) and
IdemPropNameUSmallNotVoid(PtrInt(@List^[1]),PtrInt(aValue),PLen) then
exit;
List := pointer(@PAnsiChar(PLen)[PtrUInt(List)+1]); // next
end;
result := -1;
end;
function FindShortStringListTrimLowerCase(List: PShortString; MaxValue: integer;
aValue: PUTF8Char; aValueLen: PtrInt): integer;
var PLen: PtrInt;
begin
if aValueLen<>0 then
for result := 0 to MaxValue do begin
PLen := ord(List^[0]);
inc(PUTF8Char(List));
repeat // trim lower case
if not(PUTF8Char(List)^ in ['a'..'z']) then
break;
inc(PUTF8Char(List));
dec(PLen);
until PLen=0;
if (PLen=aValueLen) and IdemPropNameUSmallNotVoid(PtrInt(aValue),PtrInt(List),PLen) then
exit;
inc(PUTF8Char(List),PLen); // next
end;
result := -1;
end;
{$ifdef HASINLINE}
function CompareMemFixed(P1, P2: Pointer; Length: PtrInt): Boolean;
label zero;
begin // cut-down version of our pure pascal CompareMem() function
{$ifndef CPUX86} result := false; {$endif}
Length := PtrInt(@PAnsiChar(P1)[Length-SizeOf(PtrInt)]);
if Length>=PtrInt(PtrUInt(P1)) then
repeat // compare one PtrInt per loop
if PPtrInt(P1)^<>PPtrInt(P2)^ then
goto zero;
inc(PPtrInt(P1));
inc(PPtrInt(P2));
until Length<PtrInt(PtrUInt(P1));
inc(Length,SizeOf(PtrInt));
dec(PtrUInt(P2),PtrUInt(P1));
if PtrInt(PtrUInt(P1))<Length then
repeat
if PByte(P1)^<>PByteArray(P2)[PtrUInt(P1)] then
goto zero;
inc(PByte(P1));
until PtrInt(PtrUInt(P1))>=Length;
result := true;
exit;
zero:
{$ifdef CPUX86} result := false; {$endif}
end;
{$endif HASINLINE}
function FindShortStringListTrimLowerCaseExact(List: PShortString; MaxValue: integer;
aValue: PUTF8Char; aValueLen: PtrInt): integer;
var PLen: PtrInt;
begin
if aValueLen<>0 then
for result := 0 to MaxValue do begin
PLen := ord(List^[0]);
inc(PUTF8Char(List));
repeat
if not(PUTF8Char(List)^ in ['a'..'z']) then
break;
inc(PUTF8Char(List));
dec(PLen);
until PLen=0;
if (PLen=aValueLen) and CompareMemFixed(aValue,List,PLen) then
exit;
inc(PUTF8Char(List),PLen);
end;
result := -1;
end;
function GetEnumNameValue(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt;
AlsoTrimLowerCase: boolean): Integer;
var List: PShortString;
MaxValue: integer;
begin
List := GetEnumInfo(aTypeInfo,MaxValue);
if (aValueLen<>0) and (List<>nil) then begin
result := FindShortStringListExact(List,MaxValue,aValue,aValueLen);
if (result<0) and AlsoTrimLowerCase then
result := FindShortStringListTrimLowerCase(List,MaxValue,aValue,aValueLen);
end else
result := -1;
end;
function GetEnumNameValueTrimmed(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt): integer;
var List: PShortString;
MaxValue: integer;
begin
List := GetEnumInfo(aTypeInfo,MaxValue);
if (aValueLen<>0) and (List<>nil) then
result := FindShortStringListTrimLowerCase(List,MaxValue,aValue,aValueLen) else
result := -1;
end;
function GetEnumNameValueTrimmedExact(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt): integer;
var List: PShortString;
MaxValue: integer;
begin
List := GetEnumInfo(aTypeInfo,MaxValue);
if (aValueLen<>0) and (List<>nil) then
result := FindShortStringListTrimLowerCaseExact(List,MaxValue,aValue,aValueLen) else
result := -1;
end;
function GetEnumNameValue(aTypeInfo: pointer; const aValue: RawUTF8;
AlsoTrimLowerCase: boolean): Integer;
begin
result := GetEnumNameValue(aTypeInfo, pointer(aValue), length(aValue),
AlsoTrimLowerCase);
end;
function GetSetName(aTypeInfo: pointer; const value): RawUTF8;
var PS: PShortString;
i,max: integer;
begin
result := '';
if GetSetInfo(aTypeInfo,max,PS) then begin
for i := 0 to max do begin
if GetBitPtr(@value,i) then
result := FormatUTF8('%%,',[result,PS^]);
inc(PByte(PS),PByte(PS)^+1); // next
end;
end;
if result<>'' then
SetLength(result,length(result)-1); // trim last comma
end;
procedure AppendShortComma(text: PAnsiChar; len: PtrInt; var result: shortstring;
trimlowercase: boolean);
begin
if trimlowercase then
while text^ in ['a'..'z'] do
if len=1 then
exit else begin
inc(text);
dec(len);
end;
if integer(ord(result[0]))+len>=255 then
exit;
if len>0 then
MoveSmall(text,@result[ord(result[0])+1],len);
inc(result[0],len+1);
result[ord(result[0])] := ',';
end;
procedure GetSetNameShort(aTypeInfo: pointer; const value; out result: ShortString;
trimlowercase: boolean);
var PS: PShortString;
i,max: integer;
begin
result := '';
if GetSetInfo(aTypeInfo,max,PS) then begin
for i := 0 to max do begin
if GetBitPtr(@value,i) then
AppendShortComma(@PS^[1],ord(PS^[0]),result,trimlowercase);
inc(PByte(PS),PByte(PS)^+1); // next
end;
end;
if result[ord(result[0])]=',' then
dec(result[0]);
end;
function GetSetNameValue(aTypeInfo: pointer; var P: PUTF8Char;
out EndOfObject: AnsiChar): cardinal;
var names: PShortString;
Text: PUTF8Char;
wasString: boolean;
MaxValue, TextLen, i: integer;
begin
result := 0;
if (P<>nil) and GetSetInfo(aTypeInfo,MaxValue,names) then begin
while (P^<=' ') and (P^<>#0) do inc(P);
if P^='[' then begin
repeat inc(P) until (P^>' ') or (P^=#0);
if P^=']' then
inc(P) else begin
repeat
Text := GetJSONField(P,P,@wasString,@EndOfObject,@TextLen);
if (Text=nil) or not wasString then begin
P := nil; // invalid input (expects a JSON array of strings)
exit;
end;
if Text^='*' then begin
if MaxValue<32 then
result := ALLBITS_CARDINAL[MaxValue+1] else
result := cardinal(-1);
break;
end;
if Text^ in ['a'..'z'] then
i := FindShortStringListExact(names,MaxValue,Text,TextLen) else
i := -1;
if i<0 then
i := FindShortStringListTrimLowerCase(names,MaxValue,Text,TextLen);
if i>=0 then
SetBitPtr(@result,i);
// unknown enum names (i=-1) would just be ignored
until EndOfObject=']';
if P=nil then
exit; // avoid GPF below if already reached the input end
end;
while not (jcEndOfJSONField in JSON_CHARS[P^]) do begin // mimics GetJSONField()
if P^=#0 then begin
P := nil;
exit; // unexpected end
end;
inc(P);
end;
EndOfObject := P^;
repeat inc(P) until (P^>' ') or (P^=#0);
end else
result := GetCardinal(GetJSONField(P,P,nil,@EndOfObject));
end;
end;
{ note: those low-level VariantTo*() functions are expected to be there
even if NOVARIANTS conditional is defined (used e.g. by SynDB.TQuery) }
function SetVariantUnRefSimpleValue(const Source: variant; var Dest: TVarData): boolean;
var typ: cardinal;
begin
result := false;
typ := TVarData(Source).VType;
if typ and varByRef=0 then
exit;
typ := typ and not varByRef;
case typ of
varVariant:
if integer(PVarData(TVarData(Source).VPointer)^.VType) in
[varEmpty..varDate,varBoolean,varShortInt..varWord64] then begin
Dest := PVarData(TVarData(Source).VPointer)^;
result := true;
end;
varEmpty..varDate,varBoolean,varShortInt..varWord64: begin
Dest.VType := typ;
Dest.VInt64 := PInt64(TVarData(Source).VAny)^;
result := true;
end;
end;
end;
function VariantToInteger(const V: Variant; var Value: integer): boolean;
var tmp: TVarData;
vt: cardinal;
begin
result := false;
vt := TVarData(V).VType;
case vt of
varNull,
varEmpty: Value := 0;
varBoolean: if TVarData(V).VBoolean then Value := 1 else Value := 0; // normalize
varSmallint: Value := TVarData(V).VSmallInt;
{$ifndef DELPHI5OROLDER}
varShortInt: Value := TVarData(V).VShortInt;
varWord: Value := TVarData(V).VWord;
varLongWord:
if TVarData(V).VLongWord<=cardinal(High(integer)) then
Value := TVarData(V).VLongWord else
exit;
{$endif}
varByte: Value := TVarData(V).VByte;
varInteger: Value := TVarData(V).VInteger;
varWord64:
if (TVarData(V).VInt64>=0) and (TVarData(V).VInt64<=High(integer)) then
Value := TVarData(V).VInt64 else
exit;
varInt64:
if (TVarData(V).VInt64>=Low(integer)) and (TVarData(V).VInt64<=High(integer)) then
Value := TVarData(V).VInt64 else
exit;
else
if SetVariantUnRefSimpleValue(V,tmp) then begin
result := VariantToInteger(variant(tmp),Value);
exit;
end else
exit;
end;
result := true;
end;
function VariantToDouble(const V: Variant; var Value: double): boolean;
var tmp: TVarData;
vt: cardinal;
begin
vt := TVarData(V).VType;
if vt=varVariant or varByRef then
result := VariantToDouble(PVariant(TVarData(V).VPointer)^,Value) else begin
result := true;
if VariantToInt64(V,tmp.VInt64) then // also handle varEmpty,varNull
Value := tmp.VInt64 else
case vt of
varDouble,varDate:
Value := TVarData(V).VDouble;
varSingle:
Value := TVarData(V).VSingle;
varCurrency:
Value := TVarData(V).VCurrency;
else begin
if SetVariantUnRefSimpleValue(V,tmp) then
result := VariantToDouble(variant(tmp),Value) else
result := false;
end;
end;
end;
end;
function VariantToDoubleDef(const V: Variant; const default: double=0): double;
begin
if not VariantToDouble(V,result) then
result := default;
end;
function VariantToCurrency(const V: Variant; var Value: currency): boolean;
var tmp: TVarData;
vt: cardinal;
begin
vt := TVarData(V).VType;
if vt=varVariant or varByRef then
result := VariantToCurrency(PVariant(TVarData(V).VPointer)^,Value) else begin
result := true;
if VariantToInt64(V,tmp.VInt64) then
Value := tmp.VInt64 else
case vt of
varDouble,varDate:
Value := TVarData(V).VDouble;
varSingle:
Value := TVarData(V).VSingle;
varCurrency:
Value := TVarData(V).VCurrency;
else
if SetVariantUnRefSimpleValue(V,tmp) then
result := VariantToCurrency(variant(tmp),Value) else
result := false;
end;
end;
end;
function VariantToBoolean(const V: Variant; var Value: Boolean): boolean;
var tmp: TVarData;
vt: cardinal;
begin
vt := TVarData(V).VType;
case vt of
varEmpty, varNull: begin
result := false;
exit;
end;
varBoolean:
Value := TVarData(V).VBoolean;
varInteger: // coming e.g. from GetJsonField()
Value := TVarData(V).VInteger=1;
varString:
Value := IdemPropNameU(RawUTF8(TVarData(V).VAny),BOOL_UTF8[true]);
{$ifndef DELPHI5OROLDER} // WideCompareText() not defined on this old RTL
varOleStr:
Value := WideCompareText(WideString(TVarData(V).VAny),'true')=0;
{$endif DELPHI5OROLDER}
{$ifdef HASVARUSTRING}
varUString: Value := {$ifdef FPC}UnicodeCompareText{$else}CompareText{$endif}(
UnicodeString(TVarData(V).VAny),'true')=0;
{$endif HASVARUSTRING}
else
if SetVariantUnRefSimpleValue(V,tmp) then
if tmp.VType=varBoolean then
Value := tmp.VBoolean else begin
result := false;
exit;
end else begin
result := false;
exit;
end;
end;
result := true;
end;
function VariantToInt64(const V: Variant; var Value: Int64): boolean;
var tmp: TVarData;
vt: cardinal;
begin
vt := TVarData(V).VType;
case vt of
varNull,
varEmpty: Value := 0;
varBoolean: if TVarData(V).VBoolean then Value := 1 else Value := 0; // normalize
varSmallint: Value := TVarData(V).VSmallInt;
{$ifndef DELPHI5OROLDER}
varShortInt: Value := TVarData(V).VShortInt;
varWord: Value := TVarData(V).VWord;
varLongWord: Value := TVarData(V).VLongWord;
{$endif}
varByte: Value := TVarData(V).VByte;
varInteger: Value := TVarData(V).VInteger;
varWord64: if TVarData(V).VInt64>=0 then
Value := TVarData(V).VInt64 else begin
result := false;
exit;
end;
varInt64: Value := TVarData(V).VInt64;
else
if SetVariantUnRefSimpleValue(V,tmp) then begin
result := VariantToInt64(variant(tmp),Value);
exit;
end else begin
result := false;
exit;
end;
end;
result := true;
end;
function VariantToInt64Def(const V: Variant; DefaultValue: Int64): Int64;
begin
if not VariantToInt64(V,result) then
result := DefaultValue;
end;
function VariantToIntegerDef(const V: Variant; DefaultValue: integer): integer;
begin
if not VariantToInteger(V,result) then
result := DefaultValue;
end;
{$ifndef NOVARIANTS}
function BinToHexDisplayLowerVariant(Bin: pointer; BinBytes: integer): variant;
begin
RawUTF8ToVariant(BinToHexDisplayLower(Bin,BinBytes),result);
end;
function VariantHexDisplayToBin(const Hex: variant; Bin: PByte; BinBytes: integer): boolean;
var tmp: RawUTF8;
wasString: boolean;
begin
VariantToUTF8(hex,tmp,wasString);
result := wasstring and HexDisplayToBin(pointer(tmp),Bin,BinBytes);
end;
function VariantToDateTime(const V: Variant; var Value: TDateTime): boolean;
var tmp: RawUTF8;
vd: TVarData;
vt: cardinal;
begin
vt := TVarData(V).VType;
if vt=varVariant or varByRef then
result := VariantToDateTime(PVariant(TVarData(V).VPointer)^,Value) else begin
result := true;
case vt of
varDouble,varDate:
Value := TVarData(V).VDouble;
varSingle:
Value := TVarData(V).VSingle;
varCurrency:
Value := TVarData(V).VCurrency;
else
if SetVariantUnRefSimpleValue(V,vd) then
result := VariantToDateTime(variant(vd),Value) else begin
VariantToUTF8(V,tmp);
Iso8601ToDateTimePUTF8CharVar(pointer(tmp),length(tmp),Value);
result := Value<>0;
end;
end;
end;
end;
procedure VariantToInlineValue(const V: Variant; var result: RawUTF8);
var tmp: RawUTF8;
wasString: boolean;
begin
VariantToUTF8(V,tmp,wasString);
if wasString then
QuotedStr(tmp,'"',result) else
result := tmp;
end;
function VariantToVariantUTF8(const V: Variant): variant;
var tmp: RawUTF8;
wasString: boolean;
begin
VariantToUTF8(V,tmp,wasString);
if wasString then
result := V else
RawUTF8ToVariant(tmp,result);
end;
procedure VariantToUTF8(const V: Variant; var result: RawUTF8;
var wasString: boolean);
var tmp: TVarData;
vt: cardinal;
begin
wasString := false;
vt := TVarData(V).VType;
with TVarData(V) do
case vt of
varEmpty,
varNull:
result := NULL_STR_VAR;
varSmallint:
Int32ToUTF8(VSmallInt,result);
{$ifndef DELPHI5OROLDER}
varShortInt:
Int32ToUTF8(VShortInt,result);
varWord:
UInt32ToUTF8(VWord,result);
varLongWord:
UInt32ToUTF8(VLongWord,result);
{$endif}
varByte:
result := SmallUInt32UTF8[VByte];
varBoolean:
if VBoolean then
result := SmallUInt32UTF8[1] else
result := SmallUInt32UTF8[0];
varInteger:
Int32ToUTF8(VInteger,result);
varInt64:
Int64ToUTF8(VInt64,result);
varWord64:
UInt64ToUTF8(VInt64,result);
varSingle:
ExtendedToStr(VSingle,SINGLE_PRECISION,result);
varDouble:
DoubleToStr(VDouble,result);
varCurrency:
Curr64ToStr(VInt64,result);
varDate: begin
wasString := true;
DateTimeToIso8601TextVar(VDate,'T',result);
end;
varString: begin
wasString := true;
{$ifdef HASCODEPAGE}
AnyAnsiToUTF8(RawByteString(VString),result);
{$else}
result := RawUTF8(VString);
{$endif}
end;
{$ifdef HASVARUSTRING}
varUString: begin
wasString := true;
RawUnicodeToUtf8(VAny,length(UnicodeString(VAny)),result);
end;
{$endif}
varOleStr: begin
wasString := true;
RawUnicodeToUtf8(VAny,length(WideString(VAny)),result);
end;
else
if SetVariantUnRefSimpleValue(V,tmp) then
VariantToUTF8(Variant(tmp),result,wasString) else
if vt=varVariant or varByRef then // complex varByRef
VariantToUTF8(PVariant(VPointer)^,result,wasString) else
if vt=varByRef or varString then begin
wasString := true;
{$ifdef HASCODEPAGE}
AnyAnsiToUTF8(PRawByteString(VString)^,result);
{$else}
result := PRawUTF8(VString)^;
{$endif}
end else
if vt=varByRef or varOleStr then begin
wasString := true;
RawUnicodeToUtf8(pointer(PWideString(VAny)^),length(PWideString(VAny)^),result);
end else
{$ifdef HASVARUSTRING}
if vt=varByRef or varUString then begin
wasString := true;
RawUnicodeToUtf8(pointer(PUnicodeString(VAny)^),length(PUnicodeString(VAny)^),result);
end else
{$endif}
VariantSaveJSON(V,twJSONEscape,result); // will handle also custom types
end;
end;
function VariantToUTF8(const V: Variant): RawUTF8;
var wasString: boolean;
begin
VariantToUTF8(V,result,wasString);
end;
function ToUTF8(const V: Variant): RawUTF8;
var wasString: boolean;
begin
VariantToUTF8(V,result,wasString);
end;
function VariantToUTF8(const V: Variant; var Text: RawUTF8): boolean;
begin
VariantToUTF8(V,Text,result);
end;
function VariantEquals(const V: Variant; const Str: RawUTF8;
CaseSensitive: boolean): boolean;
function Complex: boolean;
var wasString: boolean;
tmp: RawUTF8;
begin
VariantToUTF8(V,tmp,wasString);
if CaseSensitive then
result := (tmp=Str) else
result := IdemPropNameU(tmp,Str);
end;
var v1,v2: Int64;
vt: cardinal;
begin
vt := TVarData(V).VType;
with TVarData(V) do
case vt of
varEmpty,varNull:
result := Str='';
varBoolean:
result := VBoolean=(Str<>'');
varString:
if CaseSensitive then
result := RawUTF8(VString)=Str else
result := IdemPropNameU(RawUTF8(VString),Str);
else if VariantToInt64(V,v1) then begin
SetInt64(pointer(Str),v2);
result := v1=v2;
end else
result := Complex;
end;
end;
function VariantToString(const V: Variant): string;
var wasString: boolean;
tmp: RawUTF8;
vt: cardinal;
begin
vt := TVarData(V).VType;
with TVarData(V) do
case vt of
varEmpty,varNull:
result := ''; // default VariantToUTF8(null)='null'
{$ifdef UNICODE} // not HASVARUSTRING: here we handle string=UnicodeString
varUString:
result := UnicodeString(VAny);
else
if vt=varByRef or varUString then
result := PUnicodeString(VAny)^
{$endif}
else begin
VariantToUTF8(V,tmp,wasString);
if tmp='' then
result := '' else
UTF8DecodeToString(pointer(tmp),length(tmp),result);
end;
end;
end;
procedure RawVariantDynArrayClear(V: PVarData; n: integer);
var vt,docv: integer;
handler: TCustomVariantType;
begin
handler := nil;
docv := DocVariantVType;
repeat
vt := V^.VType;
case vt of
varEmpty..varDate,varError,varBoolean,varShortInt..varWord64: ;
varString: {$ifdef FPC}Finalize(RawUTF8(V^.VAny)){$else}RawUTF8(V^.VAny) := ''{$endif};
varOleStr: WideString(V^.VAny) := '';
{$ifdef HASVARUSTRING}
varUString: UnicodeString(V^.VAny) := '';
{$endif}
else
if vt=docv then
DocVariantType.Clear(V^) else
if vt=varVariant or varByRef then
VarClear(PVariant(V^.VPointer)^) else
if handler=nil then
if (vt and varByRef=0) and FindCustomVariantType(vt,handler) then
handler.Clear(V^) else
VarClear(variant(V^)) else
if vt=handler.VarType then
handler.Clear(V^) else
VarClear(variant(V^));
end;
inc(V);
dec(n);
until n=0;
end;
procedure VariantDynArrayClear(var Value: TVariantDynArray);
begin
FastDynArrayClear(@Value,TypeInfo(variant));
end;
{$endif NOVARIANTS}
{$ifdef UNICODE}
// this Pos() is seldom used, it was decided to only define it under
// Delphi 2009+ (which expect such a RawUTF8 specific overloaded version)
function Pos(const substr, str: RawUTF8): Integer; overload;
begin
Result := PosEx(substr,str,1);
end;
function IntToString(Value: integer): string;
var tmp: array[0..23] of AnsiChar;
P: PAnsiChar;
begin
P := StrInt32(@tmp[23],Value);
Ansi7ToString(PWinAnsiChar(P),@tmp[23]-P,result);
end;
function IntToString(Value: cardinal): string;
var tmp: array[0..23] of AnsiChar;
P: PAnsiChar;
begin
P := StrUInt32(@tmp[23],Value);
Ansi7ToString(PWinAnsiChar(P),@tmp[23]-P,result);
end;
function IntToString(Value: Int64): string;
var tmp: array[0..31] of AnsiChar;
P: PAnsiChar;
begin
P := StrInt64(@tmp[31],Value);
Ansi7ToString(PWinAnsiChar(P),@tmp[31]-P,result);
end;
function DoubleToString(Value: Double): string;
var tmp: ShortString;
begin
if Value=0 then
result := '0' else
Ansi7ToString(PWinAnsiChar(@tmp[1]),DoubleToShort(tmp,Value),result);
end;
function Curr64ToString(Value: Int64): string;
var tmp: array[0..31] of AnsiChar;
begin
Ansi7ToString(tmp,Curr64ToPChar(Value,tmp),result);
end;
{$else UNICODE}
{$ifdef PUREPASCAL}
function IntToString(Value: integer): string;
var tmp: array[0..23] of AnsiChar;
P: PAnsiChar;
begin
if cardinal(Value)<=high(SmallUInt32UTF8) then
result := SmallUInt32UTF8[Value] else begin
P := StrInt32(@tmp[23],Value);
SetString(result,P,@tmp[23]-P);
end;
end;
{$else}
function IntToString(Value: integer): string; {$ifdef FPC} nostackframe; assembler; {$endif}
asm
jmp Int32ToUTF8
end;
{$endif PUREPASCAL}
function IntToString(Value: cardinal): string;
var tmp: array[0..23] of AnsiChar;
P: PAnsiChar;
begin
if Value<=high(SmallUInt32UTF8) then
result := SmallUInt32UTF8[Value] else begin
P := StrUInt32(@tmp[23],Value);
SetString(result,P,@tmp[23]-P);
end;
end;
function IntToString(Value: Int64): string;
var tmp: array[0..31] of AnsiChar;
P: PAnsiChar;
begin
if (Value>=0) and (Value<=high(SmallUInt32UTF8)) then
result := SmallUInt32UTF8[Value] else begin
P := StrInt64(@tmp[31],Value);
SetString(result,P,@tmp[31]-P);
end;
end;
function DoubleToString(Value: Double): string;
var tmp: ShortString;
begin
if Value=0 then
result := '0' else
SetString(result,PAnsiChar(@tmp[1]),DoubleToShort(tmp,Value));
end;
function Curr64ToString(Value: Int64): string;
begin
result := Curr64ToStr(Value);
end;
{$endif UNICODE}
procedure bswap64array(a,b: PQWordArray; n: PtrInt);
{$ifdef CPUX86} {$ifdef FPC}nostackframe; assembler;{$endif}
asm
push ebx
push esi
@1: mov ebx, dword ptr[eax]
mov esi, dword ptr[eax + 4]
bswap ebx
bswap esi
mov dword ptr[edx + 4], ebx
mov dword ptr[edx], esi
add eax, 8
add edx, 8
dec ecx
jnz @1
pop esi
pop ebx
end;
{$else}
{$ifdef CPUX64}
{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
@1: mov rax, qword ptr[a]
bswap rax
mov qword ptr[b], rax
add a, 8
add b, 8
dec n
jnz @1
end;
{$else}
var i: PtrInt;
begin
for i := 0 to n-1 do
b^[i] := {$ifdef FPC}SwapEndian{$else}bswap64{$endif}(a^[i]);
end;
{$endif CPUX64}
{$endif CPUX86}
{$ifdef CPUX64}
function bswap32(a: cardinal): cardinal;
{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
mov eax, a
bswap eax
end;
function bswap64(const a: QWord): QWord; {$ifdef FPC}nostackframe; assembler; asm {$else}
asm .noframe // rcx=a (Linux: rdi)
{$endif FPC}
mov rax, a
bswap rax
end;
{$else}
{$ifdef CPUX86}
function bswap32(a: cardinal): cardinal; {$ifdef FPC} nostackframe; assembler; {$endif}
asm
bswap eax
end;
function bswap64({$ifdef FPC_X86}constref{$else}const{$endif} a: QWord): QWord;
{$ifdef FPC} nostackframe; assembler; {$endif} asm
{$ifdef FPC_X86}
mov edx, dword ptr[eax]
mov eax, dword ptr[eax + 4]
{$else}
mov edx, a.TQWordRec.L
mov eax, a.TQWordRec.H
{$endif FPC_X86}
bswap edx
bswap eax
end;
{$else}
{$ifdef FPC}
function bswap32(a: cardinal): cardinal;
begin
result := SwapEndian(a); // use fast platform-specific function
end;
function bswap64(const a: QWord): QWord;
begin
result := SwapEndian(a); // use fast platform-specific function
end;
{$else}
function bswap32(a: cardinal): cardinal;
begin
result := ((a and $ff)shl 24)or((a and $ff00)shl 8)or
((a and $ff0000)shr 8)or((a and $ff000000)shr 24);
end;
function bswap64(const a: QWord): QWord;
begin
TQWordRec(result).L := bswap32(TQWordRec(a).H);
TQWordRec(result).H := bswap32(TQWordRec(a).L);
end;
{$endif FPC}
{$endif CPUX86}
{$endif CPUX64}
{$ifndef PUREPASCAL} { these functions are implemented in asm }
{$ifndef LVCL} { don't define these functions twice }
{$ifndef FPC} { some asm functions use some low-level system.pas calls }
{$define DEFINED_INT32TOUTF8}
function Int32ToUTF8(Value : PtrInt): RawUtf8; // 3x faster than SysUtils.IntToStr
// from IntToStr32_JOH_IA32_6_a, adapted for Delphi 2009+
asm // eax=Value, edx=@result
push ebx
push edi
push esi
mov ebx, eax // value
sar ebx, 31 // 0 for +ve value or -1 for -ve value
xor eax, ebx
sub eax, ebx // abs(value)
mov esi, 10 // max dig in result
mov edi, edx // @result
cmp eax, 10
sbb esi, 0
cmp eax, 100
sbb esi, 0
cmp eax, 1000
sbb esi, 0
cmp eax, 10000
sbb esi, 0
cmp eax, 100000
sbb esi, 0
cmp eax, 1000000
sbb esi, 0
cmp eax, 10000000
sbb esi, 0
cmp eax, 100000000
sbb esi, 0
cmp eax, 1000000000
sbb esi, ebx // esi=dig (including sign character)
mov ecx, [edx] // result
test ecx, ecx
je @newstr // create new string for result
cmp dword ptr[ecx - 8], 1
jne @chgstr // reference count <> 1
cmp esi, [ecx - 4]
je @lenok // existing length = required length
sub ecx, STRRECSIZE // allocation address
push eax // abs(value)
push ecx
mov eax, esp
lea edx, [esi + STRRECSIZE + 1] // new allocation size
call System.@ReallocMem // reallocate result string
pop ecx
pop eax // abs(value)
add ecx, STRRECSIZE // result
mov [ecx - 4], esi // set new length
mov byte ptr[ecx + esi], 0 // add null terminator
mov [edi], ecx // set result address
jmp @lenok
@chgstr:mov edx, dword ptr[ecx - 8] // reference count
add edx, 1
jz @newstr // refcount = -1 (string constant)
lock dec dword ptr[ecx - 8] // decrement existing reference count
@newstr:push eax // abs(value)
mov eax, esi // length
{$ifdef UNICODE}
mov edx, CP_UTF8 // utf-8 code page for delphi 2009+
{$endif}
call System.@NewAnsiString
mov [edi], eax // set result address
mov ecx, eax // result
pop eax // abs(value)
@lenok: mov byte ptr[ecx], '-' // store '-' character (may be overwritten)
add esi, ebx // dig (excluding sign character)
sub ecx, ebx // destination of 1st dig
sub esi, 2 // dig (excluding sign character) - 2
jle @findig // 1 or 2 dig value
cmp esi, 8 // 10 dig value?
jne @setres // not a 10 dig value
sub eax, 2000000000 // dig 10 must be either '1' or '2'
mov dl, '2'
jnc @set10 // dig 10 = '2'
mov dl, '1' // dig 10 = '1'
add eax, 1000000000
@set10: mov [ecx], dl // save dig 10
mov esi, 7 // 9 dig remaining
add ecx, 1 // destination of 2nd dig
@setres:mov edi, $28f5c29 // ((2^32)+100-1)/100
@loop: mov ebx, eax // dividend
mul edi // edx = dividend div 100
mov eax, edx // set next dividend
imul edx, -200 // -2 * (100 * dividend div 100)
movzx edx, word ptr[TwoDigitLookup + ebx * 2 + edx] // dividend mod 100 in ascii
mov [ecx + esi], dx
sub esi, 2
jg @loop // loop until 1 or 2 dig remaining
@findig:pop esi
pop edi
pop ebx
jnz @last
movzx eax, word ptr[TwoDigitLookup + eax * 2]
mov [ecx], ax // save final 2 dig
ret
@last: or al, '0' // ascii adjustment
mov [ecx], al // save final dig
end;
function Int64ToUTF8(Value: Int64): RawUtf8;
asm // from IntToStr64_JOH_IA32_6_b, adapted for Delphi 2009+
push ebx
mov ecx, [ebp + 8] // low integer of val
mov edx, [ebp + 12] // high integer of val
xor ebp, ebp // clear sign flag (ebp already pushed)
mov ebx, ecx // low integer of val
test edx, edx
jnl @absval
mov ebp, 1 // ebp = 1 for -ve val or 0 for +ve val
neg ecx
adc edx, 0
neg edx
@absval:jnz @large // edx:ecx = abs(val)
test ecx, ecx
js @large
mov edx, eax // @result
mov eax, ebx // low integer of val
call Int32ToUtf8 // call fastest integer inttostr function
pop ebx
@exit: pop ebp // restore stack and exit
ret 8
@large: push edi
push esi
mov edi, eax
xor ebx, ebx
xor eax, eax
@t15: cmp edx, $00005af3 // test for 15 or more dig
jne @chk15 // 100000000000000 div $100000000
cmp ecx, $107a4000 // 100000000000000 mod $100000000
@chk15: jb @t13
@t17: cmp edx, $002386f2 // test for 17 or more dig
jne @chk17 // 10000000000000000 div $100000000
cmp ecx, $6fc10000 // 10000000000000000 mod $100000000
@chk17: jb @t1516
@t19: cmp edx, $0de0b6b3 // test for 19 dig
jne @chk19 // 1000000000000000000 div $100000000
cmp ecx, $a7640000 // 1000000000000000000 mod $100000000
@chk19: jb @t1718
mov al, 19
jmp @setl2
@t1718: mov bl, 18 // 17 or 18 dig
cmp edx, $01634578 // 100000000000000000 div $100000000
jne @setlen
cmp ecx, $5d8a0000 // 100000000000000000 mod $100000000
jmp @setlen
@t1516: mov bl, 16 // 15 or 16 dig
cmp edx, $00038d7e // 1000000000000000 div $100000000
jne @setlen
cmp ecx, $a4c68000 // 1000000000000000 mod $100000000
jmp @setlen
@t13: cmp edx, $000000e8 // test for 13 or more dig
jne @chk13 // 1000000000000 div $100000000
cmp ecx, $d4a51000 // 1000000000000 mod $100000000
@chk13: jb @t11
@t1314: mov bl, 14 // 13 or 14 dig
cmp edx, $00000918 // 10000000000000 div $100000000
jne @setlen
cmp ecx, $4e72a000 // 10000000000000 mod $100000000
jmp @setlen
@t11: cmp edx, $02 // 10, 11 or 12 dig
jne @chk11 // 10000000000 div $100000000
cmp ecx, $540be400 // 10000000000 mod $100000000
@chk11: mov bl, 11
jb @setlen // 10 dig
@t1112: mov bl, 12 // 11 or 12 dig
cmp edx, $17 // 100000000000 div $100000000
jne @setlen
cmp ecx, $4876e800 // 100000000000 mod $100000000
@setlen:sbb eax, 0 // adjust for odd/evem digit count
add eax, ebx
@setl2: push ecx // abs(val) in edx:ecx, dig in eax
push edx // save abs(val)
lea edx, [eax + ebp] // digit needed (including sign character)
mov ecx, [edi] // @result
mov esi, edx // digit needed (including sign character)
test ecx, ecx
je @newstr // create new ansistring for result
cmp dword ptr[ecx - 8], 1
jne @chgstr // reference count <> 1
cmp esi, [ecx - 4]
je @lenok // existing length = required length
sub ecx, STRRECSIZE // allocation address
push eax // abs(val)
push ecx
mov eax, esp
lea edx, [esi + STRRECSIZE + 1] // new allocation size
call System.@ReallocMem // reallocate result ansistring
pop ecx
pop eax // abs(val)
add ecx, STRRECSIZE // @result
mov [ecx - 4], esi // set new length
mov byte ptr[ecx + esi], 0 // add null terminator
mov [edi], ecx // set result address
jmp @lenok
@chgstr:mov edx, dword ptr[ecx - 8] // reference count
add edx, 1
jz @newstr // refcount = -1 (ansistring constant)
lock dec dword ptr[ecx - 8] // decrement existing reference count
@newstr:push eax // abs(val)
mov eax, esi // length
{$ifdef UNICODE}
mov edx, CP_UTF8 // utf-8 code page for delphi 2009+
{$endif}
call System.@NewAnsiString
mov [edi], eax // set result address
mov ecx, eax // @result
pop eax // abs(val)
@lenok: mov edi, [edi] // @result
sub esi, ebp // digit needed (excluding sign character)
mov byte ptr[edi], '-' // store '-' character (may be overwritten)
add edi, ebp // destination of 1st digit
pop edx // restore abs(val)
pop eax
cmp esi, 17
jl @less17 // dig < 17
je @set17 // dig = 17
cmp esi, 18
je @set18 // dig = 18
mov cl, '0' - 1
mov ebx, $a7640000 // 1000000000000000000 mod $100000000
mov ebp, $0de0b6b3 // 1000000000000000000 div $100000000
@dig19: add ecx, 1
sub eax, ebx
sbb edx, ebp
jnc @dig19
add eax, ebx
adc edx, ebp
mov [edi], cl
add edi, 1
@set18: mov cl, '0' - 1
mov ebx, $5d8a0000 // 100000000000000000 mod $100000000
mov ebp, $01634578 // 100000000000000000 div $100000000
@dig18: add ecx, 1
sub eax, ebx
sbb edx, ebp
jnc @dig18
add eax, ebx
adc edx, ebp
mov [edi], cl
add edi, 1
@set17: mov cl, '0' - 1
mov ebx, $6fc10000 // 10000000000000000 mod $100000000
mov ebp, $002386f2 // 10000000000000000 div $100000000
@dig17: add ecx, 1
sub eax, ebx
sbb edx, ebp
jnc @dig17
add eax, ebx
adc edx, ebp
mov [edi], cl
add edi, 1 // update destination
mov esi, 16 // set 16 dig left
@less17:mov ecx, 100000000 // process next 8 dig
div ecx // edx:eax = abs(val) = dividend
mov ebp, eax // dividend div 100000000
mov ebx, edx
mov eax, edx // dividend mod 100000000
mov edx, $51eb851f
mul edx
shr edx, 5 // dividend div 100
mov eax, edx // set next dividend
lea edx, [edx * 4 + edx]
lea edx, [edx * 4 + edx]
shl edx, 2 // dividend div 100 * 100
sub ebx, edx // remainder (0..99)
movzx ebx, word ptr[TwoDigitLookup + ebx * 2]
shl ebx, 16
mov edx, $51eb851f
mov ecx, eax // dividend
mul edx
shr edx, 5 // dividend div 100
mov eax, edx
lea edx, [edx * 4 + edx]
lea edx, [edx * 4 + edx]
shl edx, 2 // dividend div 100 * 100
sub ecx, edx // remainder (0..99)
or bx, word ptr[TwoDigitLookup + ecx * 2]
mov [edi + esi - 4], ebx // store 4 dig
mov ebx, eax
mov edx, $51eb851f
mul edx
shr edx, 5 // edx = dividend div 100
lea eax, [edx * 4 + edx]
lea eax, [eax * 4 + eax]
shl eax, 2 // eax = dividend div 100 * 100
sub ebx, eax // remainder (0..99)
movzx ebx, word ptr[TwoDigitLookup + ebx * 2]
movzx ecx, word ptr[TwoDigitLookup + edx * 2]
shl ebx, 16
or ebx, ecx
mov [edi + esi - 8], ebx // store 4 dig
mov eax, ebp // remainder
sub esi, 10 // dig left - 2
jz @last2
@small: mov edx, $28f5c29 // ((2^32)+100-1)/100
mov ebx, eax // dividend
mul edx
mov eax, edx // set next dividend
imul edx, -200
movzx edx, word ptr[TwoDigitLookup + ebx * 2 + edx] // dividend mod 100 in ascii
mov [edi + esi], dx
sub esi, 2
jg @small // repeat until less than 2 dig remaining
jz @last2
or al, '0' // ascii adjustment
mov [edi], al // save final digit
jmp @done
@last2: movzx eax, word ptr[TwoDigitLookup + eax * 2]
mov [edi], ax // save final 2 dig
@done: pop esi
pop edi
pop ebx
end;
function Trim(const S: RawUTF8): RawUTF8;
asm // fast implementation by John O'Harrow, modified for Delphi 2009+
test eax, eax // S = nil?
xchg eax, edx
jz System.@LStrClr // Yes, Return Empty String
mov ecx, [edx - 4] // Length(S)
cmp byte ptr[edx], ' ' // S[1] <= ' '?
jbe @left // Yes, Trim Leading Spaces
cmp byte ptr[edx + ecx - 1], ' ' // S[Length(S)] <= ' '?
jbe @right // Yes, Trim Trailing Spaces
jmp System.@LStrLAsg // No, Result := S (which occurs most time)
@left: dec ecx // Strip Leading Whitespace
jle System.@LStrClr // All Whitespace
inc edx
cmp byte ptr[edx], ' '
jbe @left
@done: cmp byte ptr[edx + ecx - 1], ' '
{$ifdef UNICODE}
jbe @right
push CP_UTF8 // UTF-8 code page for Delphi 2009+
call System.@LStrFromPCharLen // we need a call, not a jmp here
rep ret
{$else} ja System.@LStrFromPCharLen
{$endif}
@right: dec ecx // Strip Trailing Whitespace
jmp @done
end;
{$endif FPC} { above asm function had some low-level system.pas calls }
{$endif LVCL}
{$endif PUREPASCAL}
function CompareMemSmall(P1, P2: Pointer; Length: PtrUInt): Boolean;
label zero;
var c: AnsiChar; // explicit temp variable for better FPC code generation
begin
{$ifndef CPUX86} result := false; {$endif}
inc(PtrUInt(P1),PtrUInt(Length));
inc(PtrUInt(P2),PtrUInt(Length));
Length := -Length;
if Length<>0 then
repeat
c := PAnsiChar(P1)[Length];
if c<>PAnsiChar(P2)[Length] then
goto zero;
inc(Length);
until Length=0;
result := true;
{$ifdef CPUX86} exit; {$endif}
zero:
{$ifdef CPUX86} result := false; {$endif}
end;
{$ifdef HASINLINE}
procedure FillZero(var dest; count: PtrInt);
begin
FillCharFast(dest,count,0);
end;
{$else}
procedure FillZero(var dest; count: PtrInt);
asm
xor ecx, ecx
jmp dword ptr [FillCharFast]
end;
{$endif}
function IsEqual(const A,B; count: PtrInt): boolean;
var perbyte: boolean; // ensure no optimization takes place
begin
result := true;
while count>0 do begin
dec(count);
perbyte := PByteArray(@A)[count]=PByteArray(@B)[count];
result := result and perbyte;
end;
end;
function PosCharAny(Str: PUTF8Char; Characters: PAnsiChar): PUTF8Char;
var s: PAnsiChar;
c: AnsiChar;
begin
if (Str<>nil) and (Characters<>nil) and (Characters^<>#0) then
repeat
c := Str^;
if c=#0 then
break;
s := Characters;
repeat
if s^=c then begin
result := Str;
exit;
end;
inc(s);
until s^=#0;
inc(Str);
until false;
result := nil;
end;
function StringReplaceChars(const Source: RawUTF8; OldChar, NewChar: AnsiChar): RawUTF8;
var i,j,n: PtrInt;
begin
if (OldChar<>NewChar) and (Source<>'') then begin
n := length(Source);
for i := 0 to n-1 do
if PAnsiChar(pointer(Source))[i]=OldChar then begin
FastSetString(result,PAnsiChar(pointer(Source)),n);
for j := i to n-1 do
if PAnsiChar(pointer(result))[j]=OldChar then
PAnsiChar(pointer(result))[j] := NewChar;
exit;
end;
end;
result := Source;
end;
function IdemPChar2(table: PNormTable; p: PUTF8Char; up: PAnsiChar): boolean;
{$ifdef HASINLINE}inline;{$endif}
var u: AnsiChar;
begin // here p and up are expected to be <> nil
result := false;
dec(PtrUInt(p),PtrUInt(up));
repeat
u := up^;
if u=#0 then
break;
if table^[up[PtrUInt(p)]]<>u then
exit;
inc(up);
until false;
result := true;
end;
function PosI(uppersubstr: PUTF8Char; const str: RawUTF8): PtrInt;
var u: AnsiChar;
table: {$ifdef CPUX86NOTPIC}TNormTable absolute NormToUpperAnsi7{$else}PNormTable{$endif};
begin
if uppersubstr<>nil then begin
{$ifndef CPUX86NOTPIC}table := @NormToUpperAnsi7;{$endif}
u := uppersubstr^;
for result := 1 to Length(str) do
if table[str[result]]=u then
if {$ifdef CPUX86NOTPIC}IdemPChar({$else}IdemPChar2(table,{$endif}
@PUTF8Char(pointer(str))[result],PAnsiChar(uppersubstr)+1) then
exit;
end;
result := 0;
end;
function StrPosI(uppersubstr,str: PUTF8Char): PUTF8Char;
var u: AnsiChar;
table: {$ifdef CPUX86NOTPIC}TNormTable absolute NormToUpperAnsi7{$else}PNormTable{$endif};
begin
if (uppersubstr<>nil) and (str<>nil) then begin
{$ifndef CPUX86NOTPIC}table := @NormToUpperAnsi7;{$endif}
u := uppersubstr^;
inc(uppersubstr);
result := str;
while result^<>#0 do begin
if table[result^]=u then
if {$ifdef CPUX86NOTPIC}IdemPChar({$else}IdemPChar2(table,{$endif}
result+1,PAnsiChar(uppersubstr)) then
exit;
inc(result);
end;
end;
result := nil;
end;
function PosIU(substr: PUTF8Char; const str: RawUTF8): Integer;
var p: PUTF8Char;
begin
if (substr<>nil) and (str<>'') then begin
p := pointer(str);
repeat
if GetNextUTF8Upper(p)=ord(substr^) then
if IdemPCharU(p,substr+1) then begin
result := p-pointer(str);
exit;
end;
until p^=#0;
end;
result := 0;
end;
// same as PosExPas() but using char/PChar for (unicode)string process
function PosExStringPas(pSub, p: PChar; Offset: PtrUInt): PtrInt;
var len, lenSub: PtrInt;
ch: char;
pStart, pStop: PChar;
label Loop2, Loop6, TestT, Test0, Test1, Test2, Test3, Test4,
AfterTestT, AfterTest0, Ret, Exit;
begin
result := 0;
if (p=nil) or (pSub=nil) or (PtrInt(Offset)<=0) then
goto Exit;
len := PStrLen(PtrUInt(p)-_STRLEN)^;
lenSub := PStrLen(PtrUInt(pSub)-_STRLEN)^-1;
if (len<lenSub+PtrInt(Offset)) or (lenSub<0) then
goto Exit;
pStop := p+len;
inc(p,lenSub);
inc(pSub,lenSub);
pStart := p;
inc(p,Offset+3);
ch := pSub[0];
lenSub := -lenSub;
if p<pStop then goto Loop6;
dec(p,4);
goto Loop2;
Loop6: // check 6 chars per loop iteration
if ch=p[-4] then goto Test4;
if ch=p[-3] then goto Test3;
if ch=p[-2] then goto Test2;
if ch=p[-1] then goto Test1;
Loop2:
if ch=p[0] then goto Test0;
AfterTest0:
if ch=p[1] then goto TestT;
AfterTestT:
inc(p,6);
if p<pStop then goto Loop6;
dec(p,4);
if p>=pStop then goto Exit;
goto Loop2;
Test4: dec(p,2);
Test2: dec(p,2);
goto Test0;
Test3: dec(p,2);
Test1: dec(p,2);
TestT: len := lenSub;
if lenSub<>0 then
repeat
if (psub[len]<>p[len+1]) or (psub[len+1]<>p[len+2]) then
goto AfterTestT;
inc(len,2);
until len>=0;
inc(p,2);
if p<=pStop then goto Ret;
goto Exit;
Test0: len := lenSub;
if lenSub<>0 then
repeat
if (psub[len]<>p[len]) or (psub[len+1]<>p[len+1]) then
goto AfterTest0;
inc(len,2);
until len>=0;
inc(p);
Ret:
result := p-pStart;
Exit:
end;
procedure AppendCharToRawUTF8(var Text: RawUTF8; Ch: AnsiChar);
var L: PtrInt;
begin
L := length(Text);
SetLength(Text,L+1); // reallocate
PByteArray(Text)[L] := ord(Ch);
end;
procedure AppendBufferToRawUTF8(var Text: RawUTF8; Buffer: pointer; BufferLen: PtrInt);
var L: PtrInt;
begin
if BufferLen<=0 then
exit;
L := length(Text);
SetLength(Text,L+BufferLen);
MoveFast(Buffer^,pointer(PtrInt(Text)+L)^,BufferLen);
end;
procedure AppendBuffersToRawUTF8(var Text: RawUTF8; const Buffers: array of PUTF8Char);
var i,len,TextLen: PtrInt;
lens: array[0..63] of integer;
P: PUTF8Char;
begin
if high(Buffers)>high(lens) then
raise ESynException.Create('Too many params in AppendBuffersToRawUTF8()');
len := 0;
for i := 0 to high(Buffers) do begin
lens[i] := StrLen(Buffers[i]);
inc(len,lens[i]);
end;
TextLen := Length(Text);
SetLength(Text,TextLen+len);
P := pointer(Text);
inc(P,TextLen);
for i := 0 to high(Buffers) do
if Buffers[i]<>nil then begin
MoveFast(Buffers[i]^,P^,lens[i]);
inc(P,lens[i]);
end;
end;
function AppendRawUTF8ToBuffer(Buffer: PUTF8Char; const Text: RawUTF8): PUTF8Char;
var L: PtrInt;
begin
L := length(Text);
if L<>0 then begin
MoveFast(Pointer(Text)^,Buffer^,L);
inc(Buffer,L);
end;
result := Buffer;
end;
function AppendUInt32ToBuffer(Buffer: PUTF8Char; Value: PtrUInt): PUTF8Char;
var L: PtrInt;
P: PAnsiChar;
tmp: array[0..23] of AnsiChar;
begin
if Value<=high(SmallUInt32UTF8) then begin
P := pointer(SmallUInt32UTF8[Value]);
L := PStrLen(P-_STRLEN)^;
end else begin
P := StrUInt32(@tmp[23],Value);
L := @tmp[23]-P;
end;
result := Buffer;
repeat
result^ := P^;
inc(result);
inc(P);
dec(L);
until L=0;
end;
function Append999ToBuffer(Buffer: PUTF8Char; Value: PtrUInt): PUTF8Char;
var L: PtrInt;
P: PAnsiChar;
c: cardinal;
begin
P := pointer(SmallUInt32UTF8[Value]);
L := PStrLen(P-_STRLEN)^;
c := PCardinal(P)^;
Buffer[0] := AnsiChar(c); // PCardinal() write = FastMM4 FullDebugMode errors
inc(Buffer);
if L>1 then begin
Buffer^ := AnsiChar(c shr 8);
inc(Buffer);
if L>2 then begin
Buffer^ := AnsiChar(c shr 16);
inc(Buffer);
end;
end;
result := pointer(Buffer);
end;
function QuotedStr(const S: RawUTF8; Quote: AnsiChar): RawUTF8;
begin
QuotedStr(S,Quote,result);
end;
procedure QuotedStr(const S: RawUTF8; Quote: AnsiChar; var result: RawUTF8);
var i,L,quote1,nquote: PtrInt;
P,R: PUTF8Char;
tmp: pointer; // will hold a RawUTF8 with no try..finally exception block
c: AnsiChar;
begin
tmp := nil;
L := length(S);
P := pointer(S);
if (P<>nil) and (P=pointer(result)) then begin
RawUTF8(tmp) := S; // make private ref-counted copy for QuotedStr(U,'"',U)
P := pointer(tmp);
end;
nquote := 0;
{$ifdef FPC} // will use fast FPC SSE version
quote1 := IndexByte(P^,L,byte(Quote));
if quote1>=0 then
for i := quote1 to L-1 do
if P[i]=Quote then
inc(nquote);
{$else}
quote1 := 0;
for i := 0 to L-1 do
if P[i]=Quote then begin
if nquote=0 then
quote1 := i;
inc(nquote);
end;
{$endif}
FastSetString(result,nil,L+nquote+2);
R := pointer(result);
R^ := Quote;
inc(R);
if nquote=0 then begin
MoveFast(P^,R^,L);
R[L] := Quote;
end else begin
MoveFast(P^,R^,quote1);
inc(R,quote1);
inc(quote1,PtrInt(P)); // trick for reusing a register on FPC
repeat
c := PAnsiChar(quote1)^;
if c=#0 then
break;
inc(quote1);
R^ := c;
inc(R);
if c<>Quote then
continue;
R^ := c;
inc(R);
until false;
R^ := Quote;
end;
if tmp<>nil then
{$ifdef FPC}Finalize(RawUTF8(tmp)){$else}RawUTF8(tmp) := ''{$endif};
end;
function GotoEndOfQuotedString(P: PUTF8Char): PUTF8Char;
var quote: AnsiChar;
begin // P^=" or P^=' at function call
quote := P^;
inc(P);
repeat
if P^=#0 then
break else
if P^<>quote then
inc(P) else
if P[1]=quote then // allow double quotes inside string
inc(P,2) else
break; // end quote
until false;
result := P;
end; // P^='"' at function return
procedure QuotedStrJSON(P: PUTF8Char; PLen: PtrInt; var result: RawUTF8;
const aPrefix, aSuffix: RawUTF8);
var temp: TTextWriterStackBuffer;
Lp,Ls: PtrInt;
D: PUTF8Char;
begin
if (P=nil) or (PLen<=0) then
result := '""' else
if (pointer(result)=pointer(P)) or NeedsJsonEscape(P,PLen) then
with TTextWriter.CreateOwnedStream(temp) do
try
AddString(aPrefix);
Add('"');
AddJSONEscape(P,PLen);
Add('"');
AddString(aSuffix);
SetText(result);
exit;
finally
Free;
end else begin
Lp := length(aPrefix);
Ls := length(aSuffix);
FastSetString(result,nil,PLen+Lp+Ls+2);
D := pointer(result); // we checked dest result <> source P above
if Lp>0 then begin
MoveFast(pointer(aPrefix)^,D^,Lp);
inc(D,Lp);
end;
D^ := '"';
MoveFast(P^,D[1],PLen);
inc(D,PLen);
D[1] := '"';
if Ls>0 then
MoveFast(pointer(aSuffix)^,D[2],Ls);
end;
end;
procedure QuotedStrJSON(const aText: RawUTF8; var result: RawUTF8;
const aPrefix, aSuffix: RawUTF8);
begin
QuotedStrJSON(pointer(aText),Length(aText),result,aPrefix,aSuffix);
end;
function QuotedStrJSON(const aText: RawUTF8): RawUTF8;
begin
QuotedStrJSON(pointer(aText),Length(aText),result,'','');
end;
function GotoEndOfJSONString(P: PUTF8Char): PUTF8Char;
var c: AnsiChar;
begin // P^='"' at function call
inc(P);
repeat
c := P^;
if c=#0 then
break else
if c<>'\' then
if c<>'"' then // ignore \"
inc(P) else
break else // found ending "
if P[1]=#0 then // avoid potential buffer overflow issue for \#0
break else
inc(P,2); // ignore \?
until false;
result := P;
end; // P^='"' at function return
function GotoNextNotSpace(P: PUTF8Char): PUTF8Char;
begin
{$ifdef FPC}
while (P^<=' ') and (P^<>#0) do inc(P);
{$else}
if P^ in [#1..' '] then
repeat
inc(P)
until not(P^ in [#1..' ']);
{$endif}
result := P;
end;
function GotoNextNotSpaceSameLine(P: PUTF8Char): PUTF8Char;
begin
while P^ in [#9,' '] do inc(P);
result := P;
end;
function GotoNextSpace(P: PUTF8Char): PUTF8Char;
begin
if P^>' ' then
repeat
inc(P)
until P^<=' ';
result := P;
end;
function NextNotSpaceCharIs(var P: PUTF8Char; ch: AnsiChar): boolean;
begin
while (P^<=' ') and (P^<>#0) do inc(P);
if P^=ch then begin
inc(P);
result := true;
end else
result := false;
end;
function UnQuoteSQLStringVar(P: PUTF8Char; out Value: RawUTF8): PUTF8Char;
var quote: AnsiChar;
PBeg, PS: PUTF8Char;
internalquote: PtrInt;
begin
if P=nil then begin
result := nil;
exit;
end;
quote := P^; // " or '
inc(P);
// compute unquoted string length
PBeg := P;
internalquote := 0;
repeat
if P^=#0 then
break;
if P^<>quote then
inc(P) else
if P[1]=quote then begin
inc(P,2); // allow double quotes inside string
inc(internalquote);
end else
break; // end quote
until false;
if P^=#0 then begin
result := nil; // end of string before end quote -> incorrect
exit;
end;
// create unquoted string
if internalquote=0 then
// no quote within
FastSetString(Value,PBeg,P-PBeg) else begin
// unescape internal quotes
SetLength(Value,P-PBeg-internalquote);
P := PBeg;
PS := Pointer(Value);
repeat
if P^=quote then
if P[1]=quote then
inc(P) else // allow double quotes inside string
break; // end quote
PS^ := P^;
inc(PByte(PS));
inc(P);
until false;
end;
result := P+1;
end;
function UnQuoteSQLString(const Value: RawUTF8): RawUTF8;
begin
UnQuoteSQLStringVar(pointer(Value),result);
end;
function UnQuotedSQLSymbolName(const ExternalDBSymbol: RawUTF8): RawUTF8;
begin
if (ExternalDBSymbol<>'') and
(ExternalDBSymbol[1] in ['[','"','''','(']) then // e.g. for ZDBC's GetFields()
result := copy(ExternalDBSymbol,2,length(ExternalDBSymbol)-2) else
result := ExternalDBSymbol;
end;
function isSelect(P: PUTF8Char; SelectClause: PRawUTF8): boolean;
var from: PUTF8Char;
begin
if P<>nil then begin
P := SQLBegin(P);
case IdemPCharArray(P, ['SELECT','EXPLAIN ','VACUUM','PRAGMA','WITH','EXECUTE']) of
0: if P[6]<=' ' then begin
if SelectClause<>nil then begin
inc(P,7);
from := StrPosI(' FROM ',P);
if from=nil then
SelectClause^ := '' else
FastSetString(SelectClause^,P,from-P);
end;
result := true;
end else
result := false;
1: result := true;
2,3: result := P[6] in [#0..' ',';'];
4: result := (P[4]<=' ') and not (StrPosI('INSERT',P+5)<>nil) or
(StrPosI('UPDATE',P+5)<>nil) or (StrPosI('DELETE',P+5)<>nil);
5: begin // FireBird specific
P := GotoNextNotSpace(P+7);
result := IdemPChar(P,'BLOCK') and IdemPChar(GotoNextNotSpace(P+5),'RETURNS');
end
else result := false;
end;
end else
result := true; // assume '' statement is SELECT command
end;
function SQLBegin(P: PUTF8Char): PUTF8Char;
begin
if P<>nil then
repeat
if P^<=' ' then // ignore blanks
repeat
if P^=#0 then
break else
inc(P)
until P^>' ';
if PWord(P)^=ord('-')+ord('-')shl 8 then // SQL comments
repeat
inc(P)
until P^ in [#0,#10]
else
if PWord(P)^=ord('/')+ord('*')shl 8 then begin // C comments
inc(P);
repeat
inc(P);
if PWord(P)^=ord('*')+ord('/')shl 8 then begin
inc(P,2);
break;
end;
until P^=#0;
end
else break;
until false;
result := P;
end;
procedure SQLAddWhereAnd(var where: RawUTF8; const condition: RawUTF8);
begin
if where='' then
where := condition else
where := where+' and '+condition;
end;
procedure Base64MagicDecode(var ParamValue: RawUTF8);
var
tmp: RawUTF8;
begin // '\uFFF0base64encodedbinary' decode into binary (input shall have been checked)
tmp := ParamValue;
if not Base64ToBinSafe(PAnsiChar(pointer(tmp))+3,length(tmp)-3,RawByteString(ParamValue)) then
ParamValue := '';
end;
function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: RawByteString): boolean;
var ValueLen: integer;
begin // '\uFFF0base64encodedbinary' checked and decode into binary
if (Value=nil) or (Value[0]=#0) or (Value[1]=#0) or (Value[2]=#0) or
(PCardinal(Value)^ and $ffffff<>JSON_BASE64_MAGIC) then
result := false else begin
ValueLen := StrLen(Value)-3;
if ValueLen>0 then
result := Base64ToBinSafe(PAnsiChar(Value)+3,ValueLen,Blob) else
result := false;
end;
end;
function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: TSynTempBuffer): boolean;
var ValueLen: integer;
begin // '\uFFF0base64encodedbinary' checked and decode into binary
if (Value=nil) or (Value[0]=#0) or (Value[1]=#0) or (Value[2]=#0) or
(PCardinal(Value)^ and $ffffff<>JSON_BASE64_MAGIC) then
result := false else begin
ValueLen := StrLen(Value)-3;
if ValueLen>0 then
result := Base64ToBin(PAnsiChar(Value)+3,ValueLen,Blob) else
result := false;
end;
end;
function Base64MagicCheckAndDecode(Value: PUTF8Char; ValueLen: integer;
var Blob: RawByteString): boolean;
begin // '\uFFF0base64encodedbinary' checked and decode into binary
if (ValueLen<4) or (PCardinal(Value)^ and $ffffff<>JSON_BASE64_MAGIC) then
result := false else
result := Base64ToBinSafe(PAnsiChar(Value)+3,ValueLen-3,Blob);
end;
{$ifndef DEFINED_INT32TOUTF8}
function Int32ToUtf8(Value: PtrInt): RawUTF8; // faster than SysUtils.IntToStr
var tmp: array[0..23] of AnsiChar;
P: PAnsiChar;
begin
if PtrUInt(Value)<=high(SmallUInt32UTF8) then
result := SmallUInt32UTF8[Value] else begin
P := StrInt32(@tmp[23],Value);
FastSetString(result,P,@tmp[23]-P);
end;
end;
function Int64ToUtf8(Value: Int64): RawUTF8; // faster than SysUtils.IntToStr
begin
Int64ToUtf8(Value,result);
end;
function Trim(const S: RawUTF8): RawUTF8;
var I,L: PtrInt;
begin
L := Length(S);
I := 1;
while (I<=L) and (S[I]<=' ') do inc(I);
if I>L then // void string
result := '' else
if (I=1) and (S[L]>' ') then // nothing to trim
result := S else begin
while S[L]<=' ' do dec(L); // allocated trimmed
result := Copy(S,I,L-I+1);
end;
end;
{$endif DEFINED_INT32TOUTF8}
{$ifndef CPU64} // already implemented by ToUTF8(Value: PtrInt) below
function ToUTF8(Value: Int64): RawUTF8;
begin
Int64ToUTF8(Value,result);
end;
{$endif CPU64}
function ToUTF8(Value: PtrInt): RawUTF8;
begin
Int32ToUTF8(Value,result);
end;
procedure UInt32ToUtf8(Value: PtrUInt; var result: RawUTF8);
var tmp: array[0..23] of AnsiChar;
P: PAnsiChar;
begin
if Value<=high(SmallUInt32UTF8) then
result := SmallUInt32UTF8[Value] else begin
P := StrUInt32(@tmp[23],Value);
FastSetString(result,P,@tmp[23]-P);
end;
end;
function UInt32ToUtf8(Value: PtrUInt): RawUTF8;
begin
UInt32ToUTF8(Value,result);
end;
{$ifndef EXTENDEDTOSHORT_USESTR}
var // standard FormatSettings: force US decimal display (with '.' for floats)
SettingsUS: TFormatSettings;
{$endif EXTENDEDTOSHORT_USESTR}
function FloatStringNoExp(S: PAnsiChar; Precision: PtrInt): PtrInt;
var i, prec: PtrInt;
c: AnsiChar;
begin
result := ord(S[0]);
prec := result; // if no decimal
if S[1]='-' then
dec(prec);
for i := 2 to result do begin // test if scientific format -> return as this
c := S[i];
if c='E' then // should not appear
exit else
if c='.' then
if i>=precision then begin // return huge decimal number as is
result := i-1;
exit;
end else
dec(prec);
end;
if (prec>=Precision) and (prec<>result) then begin
dec(result,prec-Precision);
if S[result+1]>'5' then begin // manual rounding
prec := result;
repeat
c := S[prec];
if c<>'.' then
if c='9' then begin
S[prec] := '0';
if ((prec=2) and (S[1]='-')) or (prec=1) then begin
i := result;
inc(S,prec);
repeat // inlined Move(S[prec],S[prec+1],result);
S[i] := S[i-1];
dec(i);
until i=0;
S^ := '1';
dec(S,prec);
break;
end;
end else
if (c>='0') and (c<='8') then begin
inc(S[prec]);
break;
end else
break;
dec(prec);
until prec=0;
end; // note: this fixes http://stackoverflow.com/questions/2335162
end;
if S[result]='0' then
repeat
dec(result); // trunc any trimming 0
c := S[result];
if c<>'.' then
if c<>'0' then
break else
continue else begin
dec(result);
if (result=2) and (S[1]='-') and (S[2]='0') then begin
result := 1;
S[1] := '0'; // '-0.000' -> '0'
end;
break; // if decimal are all '0' -> return only integer part
end;
until false;
end;
function ExtendedToShortNoExp(var S: ShortString; Value: TSynExtended;
Precision: integer): integer;
begin
{$ifdef DOUBLETOSHORT_USEGRISU}
if Precision=DOUBLE_PRECISION then
DoubleToAscii(0,Precision,Value,@S) else
{$endif DOUBLETOSHORT_USEGRISU}
str(Value:0:Precision,S); // not str(Value:0,S) -> ' 0.0E+0000'
result := FloatStringNoExp(@S,Precision);
S[0] := AnsiChar(result);
end;
const // range when to switch into scientific notation - minimal 6 digits
SINGLE_HI: TSynExtended = 1E3; // for proper Delphi 5 compilation
SINGLE_LO: TSynExtended = 1E-3;
DOUBLE_HI: TSynExtended = 1E9;
DOUBLE_LO: TSynExtended = 1E-9;
EXT_HI: TSynExtended = 1E12;
EXT_LO: TSynExtended = 1E-12;
function ExtendedToShort(var S: ShortString; Value: TSynExtended;
Precision: integer): integer;
{$ifdef EXTENDEDTOSHORT_USESTR}
var scientificneeded: boolean;
valueabs: TSynExtended;
begin
{$ifdef DOUBLETOSHORT_USEGRISU}
if Precision=DOUBLE_PRECISION then begin
result := DoubleToShort(S,Value);
exit;
end;
{$endif DOUBLETOSHORT_USEGRISU}
if Value=0 then begin
PWord(@s)^ := 1 + ord('0') shl 8;
result := 1;
exit;
end;
scientificneeded := false;
valueabs := abs(Value);
if Precision<=SINGLE_PRECISION then begin
if (valueabs>SINGLE_HI) or (valueabs<SINGLE_LO) then
scientificneeded := true;
end else
{$ifdef TSYNEXTENDED80}
if Precision>DOUBLE_PRECISION then begin
if (valueabs>EXT_HI) or (valueabs<EXT_LO) then
scientificneeded := true;
end else
{$endif TSYNEXTENDED80}
if (valueabs>DOUBLE_HI) or (valueabs<DOUBLE_LO) then
scientificneeded := true;
if scientificneeded then begin
str(Value,S);
if S[1]=' ' then begin
dec(s[0]);
MoveSmall(@S[2],@S[1],ord(s[0]));
end;
result := ord(S[0]);
end else begin
str(Value:0:Precision,S); // not str(Value:0,S) -> ' 0.0E+0000'
result := FloatStringNoExp(@S,Precision);
S[0] := AnsiChar(result);
end;
end;
{$else}
{$ifdef UNICODE}
var i: PtrInt;
{$endif}
begin
// use ffGeneral: see https://synopse.info/forum/viewtopic.php?pid=442#p442
result := FloatToText(PChar(@S[1]), Value, fvExtended, ffGeneral,
Precision, 0, SettingsUS);
{$ifdef UNICODE} // FloatToText(PWideChar) is faster than FloatToText(PAnsiChar)
for i := 1 to result do
PByteArray(@S)[i] := PWordArray(PtrInt(@S)-1)[i];
{$endif}
S[0] := AnsiChar(result);
end;
{$endif EXTENDEDTOSHORT_USESTR}
function FloatToShortNan(const s: shortstring): TFloatNan;
begin
case PInteger(@s)^ and $ffdfdfdf of
3+ord('N')shl 8+ord('A')shl 16+ord('N')shl 24:
result := fnNan;
3+ord('I')shl 8+ord('N')shl 16+ord('F')shl 24,
4+ord('+')shl 8+ord('I')shl 16+ord('N')shl 24:
result := fnInf;
4+ord('-')shl 8+ord('I')shl 16+ord('N')shl 24:
result := fnNegInf;
else
result := fnNumber;
end;
end;
function FloatToStrNan(const s: RawUTF8): TFloatNan;
begin
case length(s) of
3: case PInteger(s)^ and $dfdfdf of
ord('N')+ord('A')shl 8+ord('N')shl 16: result := fnNan;
ord('I')+ord('N')shl 8+ord('F')shl 16: result := fnInf;
else result := fnNumber;
end;
4: case PInteger(s)^ and $dfdfdfdf of
ord('+')+ord('I')shl 8+ord('N')shl 16+ord('F')shl 24: result := fnInf;
ord('-')+ord('I')shl 8+ord('N')shl 16+ord('F')shl 24: result := fnNegInf;
else result := fnNumber;
end;
else result := fnNumber;
end;
end;
function ExtendedToStr(Value: TSynExtended; Precision: integer): RawUTF8;
begin
ExtendedToStr(Value,Precision,result);
end;
procedure ExtendedToStr(Value: TSynExtended; Precision: integer;
var result: RawUTF8);
var tmp: ShortString;
begin
if Value=0 then
result := SmallUInt32UTF8[0] else
FastSetString(result,@tmp[1],ExtendedToShort(tmp,Value,Precision));
end;
function FloatToJSONNan(const s: ShortString): PShortString;
begin
case PInteger(@s)^ and $ffdfdfdf of
3+ord('N')shl 8+ord('A')shl 16+ord('N')shl 24:
result := @JSON_NAN[fnNan];
3+ord('I')shl 8+ord('N')shl 16+ord('F')shl 24,
4+ord('+')shl 8+ord('I')shl 16+ord('N')shl 24:
result := @JSON_NAN[fnInf];
4+ord('-')shl 8+ord('I')shl 16+ord('N')shl 24:
result := @JSON_NAN[fnNegInf];
else
result := @s;
end;
end;
function ExtendedToJSON(var tmp: ShortString; Value: TSynExtended;
Precision: integer; NoExp: boolean): PShortString;
begin
if Value=0 then
result := @JSON_NAN[fnNumber] else begin
if noexp then
ExtendedToShortNoExp(tmp,Value,precision) else
ExtendedToShort(tmp,Value,precision);
result := FloatToJSONNan(tmp);
end;
end;
procedure Div100(Y: cardinal; var res: TDiv100Rec);
{$ifdef FPC}
var Y100: cardinal;
begin
Y100 := Y div 100; // FPC will use fast reciprocal
res.D := Y100;
res.M := Y-Y100*100; // avoid div twice
end;
{$else}
{$ifdef CPUX64}
asm
.noframe
mov r8, res
mov edx, Y
mov dword ptr [r8].TDiv100Rec.M,edx
mov eax, 1374389535
mul edx
shr edx, 5
mov dword ptr [r8].TDiv100Rec.D, edx
imul eax, edx, 100
sub dword ptr [r8].TDiv100Rec.M, eax
end;
{$else}
asm
mov dword ptr [edx].TDiv100Rec.M, eax
mov ecx, edx
mov edx, eax
mov eax, 1374389535
mul edx
shr edx, 5
mov dword ptr [ecx].TDiv100Rec.D, edx
imul eax, edx, 100
sub dword ptr [ecx].TDiv100Rec.M, eax
end;
{$endif CPUX64}
{$endif FPC}
{$ifdef DOUBLETOSHORT_USEGRISU}
// includes Fabian Loitsch's Grisu algorithm especially compiled for double
{$I SynDoubleToText.inc} // implements DoubleToAscii()
function DoubleToShort(var S: ShortString; const Value: double): integer;
var valueabs: double;
begin
valueabs := abs(Value);
if (valueabs>DOUBLE_HI) or (valueabs<DOUBLE_LO) then begin
DoubleToAscii(C_NO_MIN_WIDTH,-1,Value,@S); // = str(Value,S) for scientific notation
result := ord(S[0]);
end else
result := DoubleToShortNoExp(S,Value);
end;
function DoubleToShortNoExp(var S: ShortString; const Value: double): integer;
begin
DoubleToAscii(0,DOUBLE_PRECISION,Value,@S); // = str(Value:0:DOUBLE_PRECISION,S)
result := FloatStringNoExp(@S,DOUBLE_PRECISION);
S[0] := AnsiChar(result);
end;
{$else} // use regular Extended version
function DoubleToShort(var S: ShortString; const Value: double): integer;
begin
result := ExtendedToShort(S,Value,DOUBLE_PRECISION);
end;
function DoubleToShortNoExp(var S: ShortString; const Value: double): integer;
begin
result := ExtendedToShortNoExp(S,Value,DOUBLE_PRECISION);
end;
{$endif DOUBLETOSHORT_USEGRISU}
function DoubleToJSON(var tmp: ShortString; Value: double; NoExp: boolean): PShortString;
begin
if Value=0 then
result := @JSON_NAN[fnNumber] else begin
if noexp then
DoubleToShortNoExp(tmp,Value) else
DoubleToShort(tmp,Value);
result := FloatToJSONNan(tmp);
end;
end;
function DoubleToStr(Value: Double): RawUTF8;
begin
DoubleToStr(Value,result);
end;
procedure DoubleToStr(Value: Double; var result: RawUTF8);
var tmp: ShortString;
begin
if Value=0 then
result := SmallUInt32UTF8[0] else
FastSetString(result,@tmp[1],DoubleToShort(tmp,Value));
end;
function TrimU(const S: RawUTF8): RawUTF8;
begin
result := Trim(s);
end;
function FormatUTF8(const Format: RawUTF8; const Args: array of const): RawUTF8;
begin
FormatUTF8(Format,Args,result);
end;
type
// only supported token is %, with any const arguments
TFormatUTF8 = object
b: PTempUTF8;
L,argN: integer;
blocks: array[0..63] of TTempUTF8; // to avoid most heap allocations
procedure Parse(const Format: RawUTF8; const Args: array of const);
procedure Write(Dest: PUTF8Char);
function WriteMax(Dest: PUTF8Char; Max: PtrUInt): PUTF8Char;
end;
procedure TFormatUTF8.Parse(const Format: RawUTF8; const Args: array of const);
var F,FDeb: PUTF8Char;
begin
if length(Args)*2>=high(blocks) then
raise ESynException.Create('FormatUTF8: too many args (max=32)!');
L := 0;
argN := 0;
b := @blocks;
F := pointer(Format);
repeat
if F^=#0 then
break;
if F^<>'%' then begin
FDeb := F;
repeat
inc(F);
until (F^='%') or (F^=#0);
b^.Text := FDeb;
b^.Len := F-FDeb;
b^.TempRawUTF8 := nil;
inc(L,b^.Len);
inc(b);
if F^=#0 then
break;
end;
inc(F); // jump '%'
if argN<=high(Args) then begin
inc(L,VarRecToTempUTF8(Args[argN],b^));
if b.Len>0 then
inc(b);
inc(argN);
if F^=#0 then
break;
end else // no more available Args -> add all remaining text
if F^=#0 then
break else begin
b^.Len := length(Format)-(F-pointer(Format));
b^.Text := F;
b^.TempRawUTF8 := nil;
inc(L,b^.Len);
inc(b);
break;
end;
until false;
end;
procedure TFormatUTF8.Write(Dest: PUTF8Char);
var d: PTempUTF8;
begin
d := @blocks;
repeat
{$ifdef HASINLINE}MoveSmall(d^.Text,Dest{$else}MoveFast(d^.Text^,Dest^{$endif},d^.Len);
inc(Dest,d^.Len);
if d^.TempRawUTF8<>nil then
{$ifdef FPC}Finalize(RawUTF8(d^.TempRawUTF8)){$else}RawUTF8(d^.TempRawUTF8) := ''{$endif};
inc(d);
until d=b;
end;
function TFormatUTF8.WriteMax(Dest: PUTF8Char; Max: PtrUInt): PUTF8Char;
var d: PTempUTF8;
begin
if Max>0 then begin
inc(Max,PtrUInt(Dest));
d := @blocks;
if Dest<>nil then
repeat
if PtrUInt(Dest)+PtrUInt(d^.Len)>Max then begin // avoid buffer overflow
{$ifdef HASINLINE}MoveSmall(d^.Text,Dest{$else}MoveFast(d^.Text^,Dest^{$endif},Max-PtrUInt(Dest));
repeat
if d^.TempRawUTF8<>nil then
{$ifdef FPC}Finalize(RawUTF8(d^.TempRawUTF8)){$else}RawUTF8(d^.TempRawUTF8) := ''{$endif};
inc(d);
until d=b; // avoid memory leak
result := PUTF8Char(Max);
exit;
end;
{$ifdef HASINLINE}MoveSmall(d^.Text,Dest{$else}MoveFast(d^.Text^,Dest^{$endif},d^.Len);
inc(Dest,d^.Len);
if d^.TempRawUTF8<>nil then
{$ifdef FPC}Finalize(RawUTF8(d^.TempRawUTF8)){$else}RawUTF8(d^.TempRawUTF8) := ''{$endif};
inc(d);
until d=b;
end;
result := Dest;
end;
procedure FormatUTF8(const Format: RawUTF8; const Args: array of const;
out result: RawUTF8);
var process: TFormatUTF8;
begin
if (Format='') or (high(Args)<0) then // no formatting needed
result := Format else
if PWord(Format)^=ord('%') then // optimize raw conversion
VarRecToUTF8(Args[0],result) else begin
process.Parse(Format,Args);
if process.L<>0 then begin
FastSetString(result,nil,process.L);
process.Write(pointer(result));
end;
end;
end;
procedure FormatShort(const Format: RawUTF8; const Args: array of const;
var result: shortstring);
var process: TFormatUTF8;
begin
if (Format='') or (high(Args)<0) then // no formatting needed
SetString(result,PAnsiChar(pointer(Format)),length(Format)) else begin
process.Parse(Format,Args);
result[0] := AnsiChar(process.WriteMax(@result[1],255)-@result[1]);
end;
end;
function FormatBuffer(const Format: RawUTF8; const Args: array of const;
Dest: pointer; DestLen: PtrInt): PtrInt;
var process: TFormatUTF8;
begin
if (Dest=nil) or (DestLen<=0) then begin
result := 0;
exit; // avoid buffer overflow
end;
process.Parse(Format,Args);
result := PtrInt(process.WriteMax(Dest,DestLen))-PtrInt(Dest);
end;
function FormatToShort(const Format: RawUTF8; const Args: array of const): shortstring;
var process: TFormatUTF8;
begin // Delphi 5 has troubles compiling overloaded FormatShort()
process.Parse(Format,Args);
result[0] := AnsiChar(process.WriteMax(@result[1],255)-@result[1]);
end;
procedure FormatShort16(const Format: RawUTF8; const Args: array of const;
var result: TShort16);
var process: TFormatUTF8;
begin
if (Format='') or (high(Args)<0) then // no formatting needed
SetString(result,PAnsiChar(pointer(Format)),length(Format)) else begin
process.Parse(Format,Args);
result[0] := AnsiChar(process.WriteMax(@result[1],16)-@result[1]);
end;
end;
procedure FormatString(const Format: RawUTF8; const Args: array of const;
out result: string);
var process: TFormatUTF8;
temp: TSynTempBuffer; // will avoid most memory allocations
begin
if (Format='') or (high(Args)<0) then begin // no formatting needed
UTF8DecodeToString(pointer(Format),length(Format),result);
exit;
end;
process.Parse(Format,Args);
temp.Init(process.L);
process.Write(temp.buf);
UTF8DecodeToString(temp.buf,process.L,result);
temp.Done;
end;
function FormatString(const Format: RawUTF8; const Args: array of const): string;
begin
FormatString(Format,Args,result);
end;
function FormatUTF8(const Format: RawUTF8; const Args, Params: array of const; JSONFormat: boolean): RawUTF8;
var i, tmpN, L, A, P, len: PtrInt;
isParam: AnsiChar;
tmp: TRawUTF8DynArray;
inlin: set of 0..255;
F,FDeb: PUTF8Char;
wasString: Boolean;
const NOTTOQUOTE: array[boolean] of set of 0..31 = (
[vtBoolean,vtInteger,vtInt64{$ifdef FPC},vtQWord{$endif},vtCurrency,vtExtended],
[vtBoolean,vtInteger,vtInt64{$ifdef FPC},vtQWord{$endif},vtCurrency,vtExtended,vtVariant]);
label Txt;
begin
if Format='' then begin
result := '';
exit;
end;
if (high(Args)<0) and (high(Params)<0) then begin
// no formatting to process, but may be a const -> make unique
FastSetString(result,pointer(Format),length(Format));
exit; // e.g. _JsonFmt() will parse it in-place
end;
if high(Params)<0 then begin
FormatUTF8(Format,Args,result); // slightly faster overloaded function
exit;
end;
if Format='%' then begin
VarRecToUTF8(Args[0],result); // optimize raw conversion
exit;
end;
result := '';
tmpN := 0;
FillCharFast(inlin,SizeOf(inlin),0);
L := 0;
A := 0;
P := 0;
F := pointer(Format);
while F^<>#0 do begin
if F^<>'%' then begin
FDeb := F;
while not (F^ in [#0,'%','?']) do inc(F);
Txt: len := F-FDeb;
if len>0 then begin
inc(L,len);
if tmpN=length(tmp) then
SetLength(tmp,tmpN+8);
FastSetString(tmp[tmpN],FDeb,len); // add inbetween text
inc(tmpN);
end;
end;
if F^=#0 then
break;
isParam := F^;
inc(F); // jump '%' or '?'
if (isParam='%') and (A<=high(Args)) then begin // handle % substitution
if tmpN=length(tmp) then
SetLength(tmp,tmpN+8);
VarRecToUTF8(Args[A],tmp[tmpN]);
inc(A);
if tmp[tmpN]<>'' then begin
inc(L,length(tmp[tmpN]));
inc(tmpN);
end;
end else
if (isParam='?') and (P<=high(Params)) then begin // handle ? substitution
if tmpN=length(tmp) then
SetLength(tmp,tmpN+8);
{$ifndef NOVARIANTS}
if JSONFormat and (Params[P].VType=vtVariant) then
VariantSaveJSON(Params[P].VVariant^,twJSONEscape,tmp[tmpN]) else
{$endif}
begin
VarRecToUTF8(Params[P],tmp[tmpN]);
wasString := not (Params[P].VType in NOTTOQUOTE[JSONFormat]);
if wasString then
if JSONFormat then
QuotedStrJSON(tmp[tmpN],tmp[tmpN]) else
tmp[tmpN] := QuotedStr(tmp[tmpN],'''');
if not JSONFormat then begin
inc(L,4); // space for :():
include(inlin,tmpN);
end;
end;
inc(P);
inc(L,length(tmp[tmpN]));
inc(tmpN);
end else
if F^<>#0 then begin // no more available Args -> add all remaining text
FDeb := F;
repeat inc(F) until (F^=#0);
goto Txt;
end;
end;
if L=0 then
exit;
if not JSONFormat and (tmpN>SizeOf(inlin)shl 3) then
raise ESynException.CreateUTF8(
'Too many parameters for FormatUTF8(): %>%',[tmpN,SizeOf(inlin)shl 3]);
FastSetString(result,nil,L);
F := pointer(result);
for i := 0 to tmpN-1 do
if tmp[i]<>'' then begin
if byte(i) in inlin then begin
PWord(F)^ := ord(':')+ord('(')shl 8;
inc(F,2);
end;
L := PStrLen(PtrUInt(tmp[i])-_STRLEN)^;
MoveFast(pointer(tmp[i])^,F^,L);
inc(F,L);
if byte(i) in inlin then begin
PWord(F)^ := ord(')')+ord(':')shl 8;
inc(F,2);
end;
end;
end;
function ScanUTF8(P: PUTF8Char; PLen: PtrInt; const fmt: RawUTF8;
const values: array of pointer; ident: PRawUTF8DynArray): integer;
var
v,w: PtrInt;
F,FEnd,PEnd: PUTF8Char;
tab: PTextCharSet;
label next;
begin
result := 0;
if (fmt='') or (P=nil) or (PLen<=0) or (high(values)<0) then
exit;
if ident<>nil then
SetLength(ident^,length(values));
F := pointer(fmt);
FEnd := F+length(fmt);
PEnd := P+PLen;
for v := 0 to high(values) do
repeat
if (P^<=' ') and (P^<>#0) then // ignore any whitespace char in text
repeat
inc(P);
if P=PEnd then
exit;
until (P^>' ') or (P^=#0);
while (F^<=' ') and (F^<>#0) do begin // ignore any whitespace char in fmt
inc(F);
if F=FEnd then
exit;
end;
if F^='%' then begin // format specifier
inc(F);
if F=FEnd then
exit;
case F^ of
'd': PInteger(values[v])^ := GetNextItemInteger(P,#0);
'D': PInt64(values[v])^ := GetNextItemInt64(P,#0);
'u': PCardinal(values[v])^ := GetNextItemCardinal(P,#0);
'U': PQword(values[v])^ := GetNextItemQword(P,#0);
'f': unaligned(PDouble(values[v])^) := GetNextItemDouble(P,#0);
'F': GetNextItemCurrency(P,PCurrency(values[v])^,#0);
'x': if not GetNextItemHexDisplayToBin(P,values[v],4,#0) then
exit;
'X': if not GetNextItemHexDisplayToBin(P,values[v],8,#0) then
exit;
's','S': begin
w := 0;
while (P[w]>' ') and (P+w<=PEnd) do inc(w);
if F^='s' then
SetString(PShortString(values[v])^,PAnsiChar(P),w) else
FastSetString(PRawUTF8(values[v])^,P,w);
inc(P,w);
while (P^<=' ') and (P^<>#0) and (P<=PEnd) do inc(P);
end;
'L': begin
w := 0;
tab := @TEXT_CHARS;
while (tcNot01013 in tab[P[w]]) and (P+w<=PEnd) do inc(w);
FastSetString(PRawUTF8(values[v])^,P,w);
inc(P,w);
end;
'%': goto next;
else raise ESynException.CreateUTF8('ScanUTF8: unknown ''%'' specifier [%]',[F^,fmt]);
end;
inc(result);
tab := @TEXT_CHARS;
if (tcIdentifier in tab[F[1]]) or (ident<>nil) then begin
w := 0;
repeat inc(w) until not(tcIdentifier in tab[F[w]]) or (F+w=FEnd);
if ident<>nil then
FastSetString(ident^[v],F,w);
inc(F,w);
end else
inc(F);
if (F>=FEnd) or (P>=PEnd) then
exit;
break;
end else begin
next: while (P^<>F^) and (P<=PEnd) do inc(P);
inc(F);
inc(P);
if (F>=FEnd) or (P>=PEnd) then
exit;
end;
until false;
end;
function ScanUTF8(const text, fmt: RawUTF8; const values: array of pointer;
ident: PRawUTF8DynArray): integer;
begin
result := ScanUTF8(pointer(text),length(text),fmt,values,ident);
end;
function RawByteStringArrayConcat(const Values: array of RawByteString): RawByteString;
var i, L: PtrInt;
P: PAnsiChar;
begin
L := 0;
for i := 0 to high(Values) do
inc(L,length(Values[i]));
SetString(Result,nil,L);
P := pointer(Result);
for i := 0 to high(Values) do begin
L := length(Values[i]);
MoveFast(pointer(Values[i])^,P^,L);
inc(P,L);
end;
end;
procedure RawByteStringToBytes(const buf: RawByteString; out bytes: TBytes);
var L: Integer;
begin
L := Length(buf);
if L<>0 then begin
SetLength(bytes,L);
MoveFast(pointer(buf)^,pointer(bytes)^,L);
end;
end;
procedure BytesToRawByteString(const bytes: TBytes; out buf: RawByteString);
begin
SetString(buf,PAnsiChar(pointer(bytes)),Length(bytes));
end;
procedure ResourceToRawByteString(const ResName: string; ResType: PChar;
out buf: RawByteString; Instance: THandle);
var HResInfo: THandle;
HGlobal: THandle;
begin
if Instance=0 then
Instance := HInstance;
HResInfo := FindResource(Instance,PChar(ResName),ResType);
if HResInfo=0 then
exit;
HGlobal := LoadResource(Instance,HResInfo);
if HGlobal<>0 then begin
SetString(buf,PAnsiChar(LockResource(HGlobal)),SizeofResource(Instance,HResInfo));
UnlockResource(HGlobal); // only needed outside of Windows
FreeResource(HGlobal);
end;
end;
procedure ResourceSynLZToRawByteString(const ResName: string;
out buf: RawByteString; Instance: THandle);
var HResInfo: THandle;
HGlobal: THandle;
begin
if Instance=0 then
Instance := HInstance;
HResInfo := FindResource(Instance,PChar(ResName),PChar(10));
if HResInfo=0 then
exit;
HGlobal := LoadResource(Instance,HResInfo);
if HGlobal<>0 then // direct decompression from memory mapped .exe content
try
AlgoSynLZ.Decompress(LockResource(HGlobal),SizeofResource(Instance,HResInfo),buf);
finally
UnlockResource(HGlobal); // only needed outside of Windows
FreeResource(HGlobal);
end;
end;
function StrLenW(S: PWideChar): PtrInt;
begin
result := 0;
if S<>nil then
while true do
if S[result+0]<>#0 then
if S[result+1]<>#0 then
if S[result+2]<>#0 then
if S[result+3]<>#0 then
inc(result,4) else begin
inc(result,3);
exit;
end else begin
inc(result,2);
exit;
end else begin
inc(result);
exit;
end else
exit;
end;
function StrCompW(Str1, Str2: PWideChar): PtrInt;
begin
if Str1<>Str2 then
if Str1<>nil then
if Str2<>nil then begin
if Str1^=Str2^ then
repeat
if (Str1^=#0) or (Str2^=#0) then break;
inc(Str1);
inc(Str2);
until Str1^<>Str2^;
result := PWord(Str1)^-PWord(Str2)^;
exit;
end else
result := 1 else // Str2=''
result := -1 else // Str1=''
result := 0; // Str1=Str2
end;
{$ifdef PUREPASCAL}
function IdemPChar(p: PUTF8Char; up: PAnsiChar): boolean;
// if the beginning of p^ is same as up^ (ignore case - up^ must be already Upper)
var table: PNormTable;
u: AnsiChar;
begin
result := false;
if p=nil then
exit;
if up<>nil then begin
dec(PtrUInt(p),PtrUInt(up));
table := @NormToUpperAnsi7;
repeat
u := up^;
if u=#0 then
break;
if u<>table^[up[PtrUInt(p)]] then
exit;
inc(up);
until false;
end;
result := true;
end;
function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt;
begin
result := 0;
dec(Count,4);
if P<>nil then begin
repeat
if result>Count then
break;
if P^[result]<>Value then
if P^[result+1]<>Value then
if P^[result+2]<>Value then
if P^[result+3]<>Value then begin
inc(result,4);
continue;
end else
inc(result,3) else
inc(result,2) else
inc(result);
exit;
until false;
inc(Count,4);
repeat
if result>=Count then
break;
if P^[result]=Value then
exit else
inc(result);
until false;
end;
result := -1;
end;
function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal;
begin
result := nil;
if P=nil then
exit;
Count := PtrInt(@P[Count-4]);
repeat
if PtrUInt(P)>PtrUInt(Count) then
break;
if P^[0]<>Value then
if P^[1]<>Value then
if P^[2]<>Value then
if P^[3]<>Value then begin
P := @P[4];
continue;
end else
result := @P[3] else
result := @P[2] else
result := @P[1] else
result := pointer(P);
exit;
until false;
inc(Count,4*SizeOf(Value));
result := pointer(P);
repeat
if PtrUInt(result)>=PtrUInt(Count) then
break;
if result^=Value then
exit else
inc(result);
until false;
result := nil;
end;
function IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean;
begin
if P<>nil then begin
result := true;
Count := PtrInt(@P[Count-4]);
repeat
if PtrUInt(P)>PtrUInt(Count) then
break;
if (P^[0]=Value) or (P^[1]=Value) or (P^[2]=Value) or (P^[3]=Value) then
exit;
P := @P[4];
until false;
inc(Count,4*SizeOf(Value));
repeat
if PtrUInt(P)>=PtrUInt(Count) then
break;
if P^[0]=Value then
exit else
P := @P[1];
until false;
end;
result := false;
end;
function PosChar(Str: PUTF8Char; Chr: AnsiChar): PUTF8Char;
var c: cardinal;
begin // FPC is efficient at compiling this code
result := nil;
if Str<>nil then begin
repeat
c := PCardinal(str)^;
if ToByte(c)=0 then
exit else
if ToByte(c)=byte(Chr) then
break;
c := c shr 8;
inc(Str);
if ToByte(c)=0 then
exit else
if ToByte(c)=byte(Chr) then
break;
c := c shr 8;
inc(Str);
if ToByte(c)=0 then
exit else
if ToByte(c)=byte(Chr) then
break;
c := c shr 8;
inc(Str);
if ToByte(c)=0 then
exit else
if ToByte(c)=byte(Chr) then
break;
inc(Str);
until false;
result := Str;
end;
end;
function CompareMem(P1, P2: Pointer; Length: PtrInt): Boolean;
label zero;
begin // this code compiles well under FPC and Delphi on both 32-bit and 64-bit
Length := PtrInt(@PAnsiChar(P1)[Length-SizeOf(PtrInt)*2]); // = 2*PtrInt end
if Length>=PtrInt(PtrUInt(P1)) then begin
if PPtrInt(PtrUInt(P1))^<>PPtrInt(P2)^ then // compare first PtrInt bytes
goto zero;
inc(PPtrInt(P1));
inc(PPtrInt(P2));
dec(PtrInt(P2),PtrInt(PtrUInt(P1)));
PtrInt(PtrUInt(P1)) := PtrInt(PtrUInt(P1)) and -SizeOf(PtrInt); // align
inc(PtrInt(P2),PtrInt(PtrUInt(P1)));
if Length>=PtrInt(PtrUInt(P1)) then
repeat // compare 4 aligned PtrInt per loop
if (PPtrInt(PtrUInt(P1))^<>PPtrInt(P2)^) or (PPtrIntArray(P1)[1]<>PPtrIntArray(P2)[1]) then
goto zero;
inc(PByte(P1),SizeOf(PtrInt)*2);
inc(PByte(P2),SizeOf(PtrInt)*2);
if Length<PtrInt(PtrUInt(P1)) then
break;
if (PPtrInt(PtrUInt(P1))^<>PPtrInt(P2)^) or (PPtrIntArray(P1)[1]<>PPtrIntArray(P2)[1]) then
goto zero;
inc(PByte(P1),SizeOf(PtrInt)*2);
inc(PByte(P2),SizeOf(PtrInt)*2);
until Length<PtrInt(PtrUInt(P1));
end;
dec(Length,PtrInt(PtrUInt(P1))-SizeOf(PtrInt)*2); // back to real length
if Length>=SizeOf(PtrInt) then begin
if PPtrInt(PtrUInt(P1))^<>PPtrInt(P2)^ then
goto zero;
inc(PPtrInt(P1));
inc(PPtrInt(P2));
dec(Length,SizeOf(PtrInt));
end;
{$ifdef CPU64}
if Length>=4 then begin
if PCardinal(P1)^<>PCardinal(P2)^ then
goto zero;
inc(PCardinal(P1));
inc(PCardinal(P2));
dec(Length,4);
end;
{$endif}
if Length>=2 then begin
if PWord(P1)^<>PWord(P2)^ then
goto zero;
inc(PWord(P1));
inc(PWord(P2));
dec(Length,2);
end;
if Length>=1 then
if PByte(P1)^<>PByte(P2)^ then
goto zero;
result := true;
exit;
zero:
result := false;
end;
{$ifdef HASINLINE} // to use directly the SubStr/S arguments registers
function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt): PtrInt;
begin
result := PosExPas(pointer(SubStr),pointer(S),Offset);
end;
{$endif HASINLINE}
// from Aleksandr Sharahov's PosEx_Sha_Pas_2() - refactored for cross-platform
function PosExPas(pSub, p: PUTF8Char; Offset: PtrUInt): PtrInt;
var len, lenSub: PtrInt;
ch: AnsiChar;
pStart, pStop: PUTF8Char;
label Loop2, Loop6, TestT, Test0, Test1, Test2, Test3, Test4,
AfterTestT, AfterTest0, Ret, Exit;
begin
result := 0;
if (p=nil) or (pSub=nil) or (PtrInt(Offset)<=0) then
goto Exit;
len := PStrLen(p-_STRLEN)^;
lenSub := PStrLen(pSub-_STRLEN)^-1;
if (len<lenSub+PtrInt(Offset)) or (lenSub<0) then
goto Exit;
pStop := p+len;
inc(p,lenSub);
inc(pSub,lenSub);
pStart := p;
inc(p,Offset+3);
ch := pSub[0];
lenSub := -lenSub;
if p<pStop then goto Loop6;
dec(p,4);
goto Loop2;
Loop6: // check 6 chars per loop iteration
if ch=p[-4] then goto Test4;
if ch=p[-3] then goto Test3;
if ch=p[-2] then goto Test2;
if ch=p[-1] then goto Test1;
Loop2:
if ch=p[0] then goto Test0;
AfterTest0:
if ch=p[1] then goto TestT;
AfterTestT:
inc(p,6);
if p<pStop then goto Loop6;
dec(p,4);
if p>=pStop then goto Exit;
goto Loop2;
Test4: dec(p,2);
Test2: dec(p,2);
goto Test0;
Test3: dec(p,2);
Test1: dec(p,2);
TestT: len := lenSub;
if lenSub<>0 then
repeat
if (psub[len]<>p[len+1]) or (psub[len+1]<>p[len+2]) then
goto AfterTestT;
inc(len,2);
until len>=0;
inc(p,2);
if p<=pStop then goto Ret;
goto Exit;
Test0: len := lenSub;
if lenSub<>0 then
repeat
if (psub[len]<>p[len]) or (psub[len+1]<>p[len+1]) then
goto AfterTest0;
inc(len,2);
until len>=0;
inc(p);
Ret:
result := p-pStart;
Exit:
end;
function IdemPropNameU(const P1,P2: RawUTF8): boolean;
var L: PtrInt;
begin
L := length(P1);
if length(P2)=L then
result := IdemPropNameUSameLen(pointer(P1),pointer(P2),L) else
result := false;
end;
function StrIComp(Str1, Str2: pointer): PtrInt;
var C1,C2: byte; // integer/PtrInt are actually slower on FPC
lookupper: PByteArray; // better x86-64 / PIC asm generation
begin
result := PtrInt(PtrUInt(Str2))-PtrInt(PtrUInt(Str1));
if result<>0 then
if Str1<>nil then
if Str2<>nil then begin
lookupper := @NormToUpperAnsi7Byte;
repeat
C1 := lookupper[PByteArray(Str1)[0]];
C2 := lookupper[PByteArray(Str1)[result]];
inc(PByte(Str1));
until (C1=0) or (C1<>C2);
result := C1-C2;
end else
result := 1 else // Str2=''
result := -1; // Str1=''
end;
function StrLenPas(S: pointer): PtrInt;
label
_0, _1, _2, _3; // ugly but faster
begin
result := PtrUInt(S);
if S<>nil then begin
while true do
if PAnsiChar(result)[0]=#0 then
goto _0
else if PAnsiChar(result)[1]=#0 then
goto _1
else if PAnsiChar(result)[2]=#0 then
goto _2
else if PAnsiChar(result)[3]=#0 then
goto _3
else
inc(result, 4);
_3: inc(result);
_2: inc(result);
_1: inc(result);
_0: dec(result,PtrUInt(S)); // return length
end;
end;
function StrCompFast(Str1, Str2: pointer): PtrInt;
var c: byte;
begin
if Str1<>Str2 then
if Str1<>nil then
if Str2<>nil then begin
c := PByte(Str1)^;
if c=PByte(Str2)^ then
repeat
if c=0 then break;
inc(PByte(Str1));
inc(PByte(Str2));
c := PByte(Str1)^;
until c<>PByte(Str2)^;
result := c-PByte(Str2)^;
exit;
end else
result := 1 else // Str2=''
result := -1 else // Str1=''
result := 0; // Str1=Str2
end;
procedure YearToPChar(Y: PtrUInt; P: PUTF8Char);
var d100: PtrUInt;
tab: PWordArray;
begin
tab := @TwoDigitLookupW;
d100 := Y div 100;
PWordArray(P)[0] := tab[d100];
PWordArray(P)[1] := tab[Y-(d100*100)];
end;
procedure YearToPChar2(tab: PWordArray; Y: PtrUInt; P: PUTF8Char); {$ifdef HASINLINE}inline;{$endif}
var d100: PtrUInt;
begin
d100 := Y div 100;
PWordArray(P)[0] := tab[d100];
PWordArray(P)[1] := tab[Y-(d100*100)];
end;
function Iso8601ToTimeLog(const S: RawByteString): TTimeLog;
begin
result := Iso8601ToTimeLogPUTF8Char(pointer(S),length(S));
end;
function UpperCopy(dest: PAnsiChar; const source: RawUTF8): PAnsiChar;
var s: PAnsiChar;
c: byte;
lookupper: PByteArray; // better x86-64 / PIC asm generation
begin
s := pointer(source);
if s<>nil then begin
lookupper := @NormToUpperAnsi7Byte;
repeat
c := lookupper[ord(s^)];
if c=0 then
break;
dest^ := AnsiChar(c);
inc(s);
inc(dest);
until false;
end;
result := dest;
end;
function UpperCopyShort(dest: PAnsiChar; const source: shortstring): PAnsiChar;
var s: PByteArray;
i: PtrInt;
lookupper: PByteArray; // better x86-64 / PIC asm generation
begin
s := @source;
lookupper := @NormToUpperAnsi7Byte;
for i := 1 to s[0] do begin
dest^ := AnsiChar(lookupper[s[i]]);
inc(dest);
end;
result := dest;
end;
function IdemPCharAndGetNextLine(var source: PUTF8Char; searchUp: PAnsiChar): boolean;
begin
if source=nil then
result := false else begin
result := IdemPChar(source,searchUp);
source := GotoNextLine(source);
end;
end;
function fnv32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal;
var i: PtrInt;
begin
if buf<>nil then
for i := 0 to len-1 do
crc := (crc xor ord(buf[i]))*16777619;
result := crc;
end;
function kr32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal;
var i: PtrInt;
begin
if buf<>nil then
for i := 0 to len-1 do begin
crc := crc*31;
inc(crc,ord(buf[i]));
end;
result := crc;
end;
procedure crcblockNoSSE42(crc128, data128: PBlock128);
var c: cardinal;
tab: PCrc32tab;
begin
tab := @crc32ctab;
c := crc128^[0] xor data128^[0];
crc128^[0] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)]
xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)];
c := crc128^[1] xor data128^[1];
crc128^[1] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)]
xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)];
c := crc128^[2] xor data128^[2];
crc128^[2] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)]
xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)];
c := crc128^[3] xor data128^[3];
crc128^[3] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)]
xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)];
end;
function crc32cfast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
{$ifdef ABSOLUTEPASCALORNOTINTEL}
var tab: PCrc32tab;
begin // on ARM, we use slicing-by-4 to avoid polluting smaller L1 cache
tab := @crc32ctab;
result := not crc;
if (buf<>nil) and (len>0) then begin
repeat
if PtrUInt(buf) and 3=0 then // align to 4 bytes boundary
break;
result := tab[0,ToByte(result xor ord(buf^))] xor (result shr 8);
dec(len);
inc(buf);
until len=0;
if len>=4 then
repeat
result := result xor PCardinal(buf)^;
inc(buf,4);
dec(len,4);
result := tab[3,ToByte(result)] xor
tab[2,ToByte(result shr 8)] xor
tab[1,ToByte(result shr 16)] xor
tab[0,ToByte(result shr 24)];
until len<4;
while len>0 do begin
result := tab[0,ToByte(result xor ord(buf^))] xor (result shr 8);
dec(len);
inc(buf);
end;
end;
result := not result;
end;
{$else}
{$ifdef FPC} nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
{$ifndef win64}
mov r8d, len
{$endif}
mov eax, crc
xor ecx, ecx
test buf, buf // buf=rdx/rsi len=r8
jz @z
neg r8
jz @z
not eax
lea r9, [rip + crc32ctab]
cmp r8, -8
jb @head
@sml: mov cl, byte ptr[buf]
inc buf
xor cl, al
shr eax, 8
xor eax, dword ptr[rcx * 4 + r9]
inc r8
jnz @sml
@0: not eax
@z: ret
@head: test buf, 7
jz @align
mov cl, byte ptr[buf]
inc buf
xor cl, al
shr eax, 8
xor eax, dword ptr[rcx * 4 + r9]
inc r8
jnz @head
not eax
ret
@align: sub buf, r8
add r8, 8
jg @done
xor r11, r11
@by8: mov r10d, eax
mov rcx, qword ptr[buf + r8 - 8]
xor r10d, ecx
shr rcx, 32
mov r11b, cl
shr ecx, 8
mov eax, dword ptr[r11 * 4 + r9 + 1024 * 3]
mov r11b, cl
shr ecx, 8
xor eax, dword ptr[r11 * 4 + r9 + 1024 * 2]
mov r11b, cl
shr ecx, 8
xor eax, dword ptr[r11 * 4 + r9 + 1024 * 1]
mov r11b, cl
xor eax, dword ptr[r11 * 4 + r9 + 1024 * 0]
mov ecx, r10d
mov r11b, cl
shr ecx, 8
xor eax, dword ptr[r11 * 4 + r9 + 1024 * 7]
mov r11b, cl
shr ecx, 8
xor eax, dword ptr[r11 * 4 + r9 + 1024 * 6]
mov r11b, cl
shr ecx, 8
xor eax, dword ptr[r11 * 4 + r9 + 1024 * 5]
mov r11b, cl
xor eax, dword ptr[r11 * 4 + r9 + 1024 * 4]
add r8, 8
jle @by8
@done: sub r8, 8
jge @e
@tail: mov cl, byte ptr[buf + r8]
xor cl, al
shr eax, 8
xor eax, dword ptr[rcx * 4 + r9]
inc r8
jnz @tail
@e: not eax
end;
{$endif ABSOLUTEPASCALORNOTINTEL}
function ToVarInt32(Value: PtrInt; Dest: PByte): PByte;
begin // 0=0,1=1,2=-1,3=2,4=-2...
if Value<0 then
// -1->2, -2->4..
Value := (-Value) shl 1 else
if Value>0 then
// 1->1, 2->3..
Value := (Value shl 1)-1;
// 0->0
result := ToVarUInt32(Value,Dest);
end;
function ToVarUInt32(Value: cardinal; Dest: PByte): PByte;
label _1,_2,_3; // ugly but fast
begin
if Value>$7f then begin
if Value<$80 shl 7 then goto _1 else
if Value<$80 shl 14 then goto _2 else
if Value<$80 shl 21 then goto _3;
Dest^ := (Value and $7F) or $80;
Value := Value shr 7;
inc(Dest);
_3: Dest^ := (Value and $7F) or $80;
Value := Value shr 7;
inc(Dest);
_2: Dest^ := (Value and $7F) or $80;
Value := Value shr 7;
inc(Dest);
_1: Dest^ := (Value and $7F) or $80;
Value := Value shr 7;
inc(Dest);
end;
Dest^ := Value;
inc(Dest);
result := Dest;
end;
{$ifdef CPUX64} // very efficient branchless asm - rcx/rdi=A rdx/rsi=B
function SortDynArrayInteger(const A,B): integer;
{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
mov r8d, dword ptr[A]
mov edx, dword ptr[B]
xor eax, eax
xor ecx, ecx
cmp r8d, edx
setl cl
setg al
sub eax, ecx
end;
function SortDynArrayCardinal(const A,B): integer;
{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
mov ecx, dword ptr[A]
mov edx, dword ptr[B]
xor eax, eax
cmp ecx, edx
seta al
sbb eax, 0
end;
function SortDynArrayInt64(const A,B): integer;
{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
mov r8, qword ptr[A]
mov rdx, qword ptr[B]
xor eax, eax
xor ecx, ecx
cmp r8, rdx
setl cl
setg al
sub eax, ecx
end;
function SortDynArrayQWord(const A,B): integer;
{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
mov rcx, qword ptr[A]
mov rdx, qword ptr[B]
xor eax, eax
cmp rcx, rdx
seta al
sbb eax, 0
end;
function SortDynArrayPointer(const A,B): integer;
{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
mov rcx, qword ptr[A]
mov rdx, qword ptr[B]
xor eax, eax
cmp rcx, rdx
seta al
sbb eax, 0
end;
function SortDynArrayDouble(const A,B): integer;
{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
movsd xmm0, qword ptr[A]
movsd xmm1, qword ptr[B]
xor eax, eax
xor edx, edx
comisd xmm0, xmm1
seta al
setb dl
sub eax, edx
end;
function SortDynArraySingle(const A,B): integer;
{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
movss xmm0, dword ptr[A]
movss xmm1, dword ptr[B]
xor eax, eax
xor edx, edx
comiss xmm0, xmm1
seta al
setb dl
sub eax, edx
end;
function SortDynArrayAnsiString(const A,B): integer;
{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
mov rcx, qword ptr[A]
mov rdx, qword ptr[B]
cmp rcx, rdx // A=B (happens with string refcounting)
je @0
test rcx, rdx // A^ or B^ may be nil i.e. ''
jz @n1
@s: mov al, byte ptr[rcx] // by char comparison
cmp al, byte ptr[rdx]
jne @ne
inc rcx
inc rdx
test al, al
jnz @s
@0: xor eax, eax
ret
@n1: test rcx, rcx
jz @less // A='' -> -1
test rdx, rdx
jnz @s // B='' -> 1
@1: mov eax, 1
ret
@ne: jnc @1
@less: mov eax, -1
end; // note: SSE4.2 read up to 16 bytes after buffer, this version won't
{$else}
function SortDynArrayInteger(const A,B): integer;
begin
result := ord(integer(A)>integer(B))-ord(integer(A)<integer(B));
end;
function SortDynArrayCardinal(const A,B): integer;
begin
result := ord(cardinal(A)>cardinal(B))-ord(cardinal(A)<cardinal(B));
end;
function SortDynArrayInt64(const A,B): integer;
begin
result := ord(Int64(A)>Int64(B))-ord(Int64(A)<Int64(B));
end;
function SortDynArrayQWord(const A,B): integer;
begin
result := ord(QWord(A)>QWord(B))-ord(QWord(A)<QWord(B));
end;
function SortDynArrayPointer(const A,B): integer;
begin
result := ord(PtrUInt(A)>PtrUInt(B))-ord(PtrUInt(A)<PtrUInt(B));
end;
function SortDynArrayDouble(const A,B): integer;
begin
result := ord(double(A)>double(B))-ord(double(A)<double(B));
end;
function SortDynArraySingle(const A,B): integer;
begin
result := ord(single(A)>single(B))-ord(single(A)<single(B));
end;
function SortDynArrayAnsiString(const A,B): integer;
begin
result := StrCompFast(pointer(A),pointer(B));
end;
{$endif CPUX64}
function CompareQWord(A, B: QWord): integer;
begin
result := ord(A>B)-ord(A<B);
end;
function SortDynArrayAnsiStringI(const A,B): integer;
begin
result := StrIComp(PUTF8Char(A),PUTF8Char(B));
end;
function SortDynArrayRawByteString(const A,B): integer;
var p1,p2: PByteArray;
l1,l2,i,l: PtrInt; // FPC will use very efficiently the CPU registers
begin // we can't use StrComp() since a RawByteString may contain #0
p1 := pointer(A);
p2 := pointer(B);
if p1<>p2 then
if p1<>nil then
if p2<>nil then begin
l1 := PStrLen(PtrUInt(p1)-_STRLEN)^;
l2 := PStrLen(PtrUInt(p2)-_STRLEN)^;
l := l1;
if l2<l1 then
l := l2;
i := 0;
repeat
result := p1[i];
dec(result,p2[i]);
if result<>0 then
exit;
inc(i);
until i>=l;
result := l1-l2;
end else
result := 1 else // p2=''
result := -1 else // p1=''
result := 0; // p1=p2
end;
function SortDynArrayPUTF8Char(const A,B): integer;
begin
result := StrCompFast(pointer(A),pointer(B));
end;
{$else PUREPASCAL}
function IdemPChar(p: PUTF8Char; up: PAnsiChar): boolean;
{$ifdef FPC}nostackframe; assembler;{$endif}
asm
test eax, eax
jz @e // P=nil -> false
test edx, edx
push ebx
jz @t // up=nil -> true
xor ebx, ebx
@1: mov ecx, [edx] // optimized for DWORD aligned read up^
test cl, cl
mov bl, [eax]
jz @t // up^[0]=#0 -> OK
cmp cl, byte ptr[ebx + NormToUpperAnsi7] // NormToUpperAnsi7[p^[0]]
jne @f
mov bl, [eax + 1]
test ch, ch
jz @t // up^[1]=#0 -> OK
cmp ch, byte ptr[ebx + NormToUpperAnsi7] // NormToUpperAnsi7[p^[1]]
jne @f
shr ecx, 16 // cl=up^[2] ch=up^[3]
mov bl, [eax + 2]
test cl, cl
jz @t // up^[2]=#0 -> OK
cmp cl, byte ptr[ebx + NormToUpperAnsi7] // NormToUpperAnsi7[p^[2]]
jne @f
mov bl, [eax + 3]
add eax, 4
add edx, 4
test ch, ch
jz @t // up^[3]=#0 -> OK
cmp ch, byte ptr[ebx + NormToUpperAnsi7] // NormToUpperAnsi7[p^[3]]
je @1
@f: pop ebx // NormToUpperAnsi7[p^]<>up^ -> FALSE
@e: xor eax, eax
ret
@t: pop ebx // up^=#0 -> TRUE
mov al, 1
end;
function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt;
{$ifdef FPC}nostackframe; assembler;{$endif}
asm
push eax
call IntegerScan
pop edx
test eax, eax
jnz @e
dec eax // returns -1
ret
@e: sub eax, edx
shr eax, 2
end;
function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal;
{$ifdef FPC}nostackframe; assembler;{$endif}
asm // eax=P, edx=Count, Value=ecx
test eax, eax
jz @ok0 // avoid GPF
cmp edx, 8
jb @s2
nop
nop
nop // @s1 loop align
@s1: sub edx, 8
cmp [eax], ecx
je @ok0
cmp [eax + 4], ecx
je @ok4
cmp [eax + 8], ecx
je @ok8
cmp [eax + 12], ecx
je @ok12
cmp [eax + 16], ecx
je @ok16
cmp [eax + 20], ecx
je @ok20
cmp [eax + 24], ecx
je @ok24
cmp [eax + 28], ecx
je @ok28
add eax, 32
cmp edx, 8
jae @s1
@s2: test edx, edx
jz @z
cmp [eax], ecx
je @ok0
dec edx
jz @z
cmp [eax + 4], ecx
je @ok4
dec edx
jz @z
cmp [eax + 8], ecx
je @ok8
dec edx
jz @z
cmp [eax + 12], ecx
je @ok12
dec edx
jz @z
cmp [eax + 16], ecx
je @ok16
dec edx
jz @z
cmp [eax + 20], ecx
je @ok20
dec edx
jz @z
cmp [eax + 24], ecx
je @ok24
@z: xor eax, eax // return nil if not found
ret
@ok0: rep ret
@ok28: add eax, 28
ret
@ok24: add eax, 24
ret
@ok20: add eax, 20
ret
@ok16: add eax, 16
ret
@ok12: add eax, 12
ret
@ok8: add eax, 8
ret
@ok4: add eax, 4
end;
function IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean;
{$ifdef FPC}nostackframe; assembler;{$endif}
asm // eax=P, edx=Count, Value=ecx
test eax, eax
jz @z // avoid GPF
cmp edx, 8
jae @s1
jmp dword ptr[edx * 4 + @Table]
@Table: dd @z, @1, @2, @3, @4, @5, @6, @7
@s1: // fast search by 8 integers (pipelined instructions)
sub edx, 8
cmp [eax], ecx
je @ok
cmp [eax + 4], ecx
je @ok
cmp [eax + 8], ecx
je @ok
cmp [eax + 12], ecx
je @ok
cmp [eax + 16], ecx
je @ok
cmp [eax + 20], ecx
je @ok
cmp [eax + 24], ecx
je @ok
cmp [eax + 28], ecx
je @ok
add eax, 32
cmp edx, 8
jae @s1
jmp dword ptr[edx * 4 + @Table]
@7: cmp [eax + 24], ecx
je @ok
@6: cmp [eax + 20], ecx
je @ok
@5: cmp [eax + 16], ecx
je @ok
@4: cmp [eax + 12], ecx
je @ok
@3: cmp [eax + 8], ecx
je @ok
@2: cmp [eax + 4], ecx
je @ok
@1: cmp [eax], ecx
je @ok
@z: xor eax, eax
ret
@ok: mov al, 1
end;
function PosChar(Str: PUTF8Char; Chr: AnsiChar): PUTF8Char;
{$ifdef FPC}nostackframe; assembler;{$endif}
asm // faster version by AB - eax=Str dl=Chr
test eax, eax
jz @z
@1: mov ecx, dword ptr [eax]
cmp cl, dl
je @z
inc eax
test cl, cl
jz @e
cmp ch, dl
je @z
inc eax
test ch, ch
jz @e
shr ecx, 16
cmp cl, dl
je @z
inc eax
test cl, cl
jz @e
cmp ch, dl
je @z
inc eax
test ch, ch
jnz @1
@e: xor eax, eax
ret
@z: db $f3 // rep ret
end;
function CompareMem(P1, P2: Pointer; Length: PtrInt): Boolean;
{$ifdef FPC}nostackframe; assembler;{$endif}
asm // eax=P1 edx=P2 ecx=Length
cmp eax, edx
je @0 // P1=P2
sub ecx, 8
jl @small
push ebx
mov ebx, [eax] // Compare First 4 Bytes
cmp ebx, [edx]
jne @setbig
lea ebx, [eax + ecx] // Compare Last 8 Bytes
add edx, ecx
mov eax, [ebx]
cmp eax, [edx]
jne @setbig
mov eax, [ebx + 4]
cmp eax, [edx + 4]
jne @setbig
sub ecx, 4
jle @true // All Bytes already Compared
neg ecx // ecx=-(Length-12)
add ecx, ebx // DWORD Align Reads
and ecx, -4
sub ecx, ebx
@loop: mov eax, [ebx + ecx] // Compare 8 Bytes per Loop
cmp eax, [edx + ecx]
jne @setbig
mov eax, [ebx + ecx + 4]
cmp eax, [edx + ecx + 4]
jne @setbig
add ecx, 8
jl @loop
@true: pop ebx
@0: mov al, 1
ret
@setbig:pop ebx
setz al
ret
@small: add ecx, 8 // ecx=0..7
jle @0 // Length <= 0
neg ecx // ecx=-1..-7
lea ecx, [@1 + ecx * 8 + 8] // each @#: block below = 8 bytes
jmp ecx
@7: mov cl, [eax + 6]
cmp cl, [edx + 6]
jne @setsml
@6: mov ch, [eax + 5]
cmp ch, [edx + 5]
jne @setsml
@5: mov cl, [eax + 4]
cmp cl, [edx + 4]
jne @setsml
@4: mov ch, [eax + 3]
cmp ch, [edx + 3]
jne @setsml
@3: mov cl, [eax + 2]
cmp cl, [edx + 2]
jne @setsml
@2: mov ch, [eax + 1]
cmp ch, [edx + 1]
jne @setsml
@1: mov al, [eax]
cmp al, [edx]
@setsml:setz al
end;
function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt): integer;
{$ifdef FPC}nostackframe; assembler;{$endif}
asm // eax=SubStr, edx=S, ecx=Offset
push ebx
push esi
push edx
test eax, eax
jz @notfnd // exit if SubStr=''
test edx, edx
jz @notfnd // exit if S=''
mov esi, ecx
mov ecx, [edx - 4] // length(S)
mov ebx, [eax - 4] // length(SubStr)
add ecx, edx
sub ecx, ebx // ecx = max start pos for full match
lea edx, [edx + esi - 1] // edx = start position
cmp edx, ecx
jg @notfnd // startpos > max start pos
cmp ebx, 1
jle @onec // optimized loop for length(SubStr)<=1
push edi
push ebp
lea edi, [ebx - 2] // edi = length(SubStr)-2
mov esi, eax // esi = SubStr
movzx ebx, byte ptr[eax] // bl = search character
nop; nop
@l: cmp bl, [edx] // compare 2 characters per @l
je @c1fnd
@notc1: cmp bl, [edx + 1]
je @c2fnd
@notc2: add edx, 2
cmp edx, ecx // next start position <= max start position
jle @l
pop ebp
pop edi
@notfnd:xor eax, eax // returns 0 if not fnd
pop edx
pop esi
pop ebx
ret
@c1fnd: mov ebp, edi // ebp = length(SubStr)-2
@c1l: movzx eax, word ptr[esi + ebp]
cmp ax, [edx + ebp] // compare 2 chars per @c1l (may include #0)
jne @notc1
sub ebp, 2
jnc @c1l
pop ebp
pop edi
jmp @setres
@c2fnd: mov ebp, edi // ebp = length(SubStr)-2
@c2l: movzx eax, word ptr[esi + ebp]
cmp ax, [edx + ebp + 1] // compare 2 chars per @c2l (may include #0)
jne @notc2
sub ebp, 2
jnc @c2l
pop ebp
pop edi
jmp @chkres
@onec: jl @notfnd // needed for zero-length non-nil strings
movzx eax, byte ptr[eax] // search character
@charl: cmp al, [edx]
je @setres
cmp al, [edx + 1]
je @chkres
add edx, 2
cmp edx, ecx
jle @charl
jmp @notfnd
@chkres:cmp edx, ecx // check within ansistring
jge @notfnd
add edx, 1
@setres:pop ecx // ecx = S
pop esi
pop ebx
neg ecx
lea eax, [edx + ecx + 1]
end;
function IdemPropNameU(const P1,P2: RawUTF8): boolean;
{$ifdef FPC}nostackframe; assembler;{$endif}
asm // eax=p1, edx=p2
cmp eax, edx
je @out1
test eax, edx
jz @maybenil
@notnil:mov ecx, [eax - 4] // compare lengths
cmp ecx, [edx - 4]
jne @out1
push ebx
lea edx, [edx + ecx - 4] // may include the length for shortest strings
lea ebx, [eax + ecx - 4]
neg ecx
mov eax, [ebx] // compare last 4 chars
xor eax, [edx]
and eax, $dfdfdfdf // case insensitive
jne @out2
@by4: add ecx, 4
jns @match
mov eax, [ebx + ecx]
xor eax, [edx + ecx]
and eax, $dfdfdfdf // case insensitive
je @by4
@out2: pop ebx
@out1: setz al
ret
@match: mov al, 1
pop ebx
ret
@maybenil: // here we know that eax<>edx
test eax, eax
jz @nil0 // eax=nil and eax<>edx -> edx<>nil -> false
test edx, edx
jnz @notnil
mov al, dl // eax<>nil and edx=nil -> false
@nil0:
end;
function IdemPropNameUSameLen(P1,P2: PUTF8Char; P1P2Len: PtrInt): boolean;
{$ifdef FPC}nostackframe; assembler;{$endif}
asm // eax=p1, edx=p2, ecx=P1P2Len
cmp eax, edx
je @out2
cmp ecx, 4
jbe @sml
push ebx
lea edx, [edx + ecx - 4]
lea ebx, [eax + ecx - 4]
neg ecx
mov eax, [ebx] // compare last 4 chars
xor eax, [edx]
and eax, $dfdfdfdf // case insensitive
jne @out1
@by4: add ecx, 4
jns @match
mov eax, [ebx + ecx]
xor eax, [edx + ecx]
and eax, $dfdfdfdf // case insensitive
je @by4
@out1: pop ebx
@out2: setz al
ret
nop
nop
@match: pop ebx
mov al, 1
ret
@mask: dd 0, $df, $dfdf, $dfdfdf, $dfdfdfdf // compare 1..4 chars
@sml: test ecx, ecx
jz @smlo // p1p2len=0
mov eax, [eax]
xor eax, [edx]
and eax, dword ptr[@mask + ecx * 4]
@smlo: setz al
end;
function StrIComp(Str1, Str2: pointer): PtrInt;
{$ifdef FPC}nostackframe; assembler;{$endif}
asm // faster version by AB, from Agner Fog's original
mov ecx, eax
test eax, edx
jz @n
@ok: sub edx, eax
jz @0
@10: mov al, [ecx]
cmp al, [ecx + edx]
jne @20
inc ecx
test al, al
jnz @10 // continue with next byte
// terminating zero found. Strings are equal
@0: xor eax, eax
ret
@20: // bytes are different. check case
xor al, 20H // toggle case
cmp al, [ecx + edx]
jne @30
// possibly differing only by case. Check if a-z
or al, 20H // upper case
sub al, 'a'
cmp al, 'z' - 'a'
ja @30 // not a-z
// a-z and differing only by case
inc ecx
jmp @10 // continue with next byte
@30: // bytes are different,even after changing case
movzx eax, byte[ecx] // get original value again
sub eax, 'A'
cmp eax, 'Z' - 'A'
ja @40
add eax, 20H
@40: movzx edx, byte[ecx + edx]
sub edx, 'A'
cmp edx, 'Z' - 'A'
ja @50
add edx, 20H
@50: sub eax, edx // subtract to get result
ret
@n: cmp eax, edx
je @0
test eax, eax // Str1='' ?
jz @max
test edx, edx // Str2='' ?
jnz @ok
mov eax, 1
ret
@max: dec eax
end;
function StrLenPas(S: pointer): PtrInt;
{$ifdef FPC}nostackframe; assembler;{$endif}
asm // slower than x86/SSE* StrLen(), but won't read any byte beyond the string
mov edx, eax
test eax, eax
jz @0
xor eax, eax
@s: cmp byte ptr[eax + edx + 0], 0
je @0
cmp byte ptr[eax + edx + 1], 0
je @1
cmp byte ptr[eax + edx + 2], 0
je @2
cmp byte ptr[eax + edx + 3], 0
je @3
add eax, 4
jmp @s
@1: inc eax
ret
@0: rep ret
@2: add eax, 2
ret
@3: add eax, 3
end;
function StrCompFast(Str1, Str2: pointer): PtrInt;
{$ifdef FPC}nostackframe; assembler;{$endif}
asm // no branch taken in case of not equal first char
cmp eax, edx
je @zero // same string or both nil
test eax, edx
jz @maynil
@1: mov cl, [eax]
mov ch, [edx]
inc eax
inc edx
test cl, cl
jz @exit
cmp cl, ch
je @1
@exit: movzx eax, cl
movzx edx, ch
sub eax, edx
ret
@maynil:test eax, eax // Str1='' ?
jz @max
test edx, edx // Str2='' ?
jnz @1
mov eax, 1
ret
@max: dec eax
ret
@zero: xor eax, eax
end;
const
EQUAL_EACH = 8; // see https://msdn.microsoft.com/en-us/library/bb531463
NEGATIVE_POLARITY = 16;
function StrCompSSE42(Str1, Str2: pointer): PtrInt;
{$ifdef FPC}nostackframe; assembler;{$endif}
asm // warning: may read up to 15 bytes beyond the string itself
test eax, edx
jz @n
@ok: sub eax, edx
{$ifdef HASAESNI}
movups xmm0, dqword [edx]
pcmpistri xmm0, dqword [edx + eax], EQUAL_EACH + NEGATIVE_POLARITY // result in ecx
{$else}
db $F3,$0F,$6F,$02
db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY
{$endif}
ja @1
jc @2
xor eax, eax
ret
@1: add edx, 16
{$ifdef HASAESNI}
movups xmm0, dqword [edx]
pcmpistri xmm0, dqword [edx + eax], EQUAL_EACH + NEGATIVE_POLARITY // result in ecx
{$else}
db $F3,$0F,$6F,$02
db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY
{$endif}
ja @1
jc @2
@0: xor eax, eax // Str1=Str2
ret
@n: cmp eax, edx
je @0
test eax, eax // Str1='' ?
jz @max
test edx, edx // Str2='' ?
jnz @ok
mov eax, 1
ret
@max: dec eax
ret
@2: add eax, edx
movzx eax, byte ptr [eax+ecx]
movzx edx, byte ptr [edx+ecx]
sub eax, edx
end;
function SortDynArrayAnsiStringSSE42(const A,B): integer;
{$ifdef FPC}nostackframe; assembler;{$endif}
asm // warning: may read up to 15 bytes beyond the string itself
mov eax, [eax]
mov edx, [edx]
test eax, edx
jz @n
@ok: sub eax, edx
jz @0
{$ifdef HASAESNI}
movups xmm0, dqword [edx] // result in ecx
pcmpistri xmm0, dqword [edx+eax], EQUAL_EACH + NEGATIVE_POLARITY
{$else}
db $F3,$0F,$6F,$02
db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY
{$endif}
ja @1
jc @2
xor eax, eax
ret
@1: add edx, 16
{$ifdef HASAESNI}
movups xmm0, dqword [edx] // result in ecx
pcmpistri xmm0, dqword [edx+eax], EQUAL_EACH + NEGATIVE_POLARITY
{$else}
db $F3,$0F,$6F,$02
db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY
{$endif}
ja @1
jc @2
@0: xor eax, eax // Str1=Str2
ret
@n: cmp eax, edx
je @0
test eax, eax // Str1='' ?
jz @max
test edx, edx // Str2='' ?
jnz @ok
mov eax, -1
ret
@max: inc eax
ret
@2: add eax, edx
movzx eax, byte ptr [eax+ecx]
movzx edx, byte ptr [edx+ecx]
sub eax, edx
end;
function StrLenSSE42(S: pointer): PtrInt;
{$ifdef FPC}nostackframe; assembler;{$endif}
asm // warning: may read up to 15 bytes beyond the string itself
mov edx, eax // copy pointer
test eax, eax
jz @null // returns 0 if S=nil
xor eax, eax
{$ifdef HASAESNI}
pxor xmm0, xmm0
pcmpistri xmm0, dqword[edx], EQUAL_EACH // comparison result in ecx
{$else}
db $66, $0F, $EF, $C0
db $66, $0F, $3A, $63, $02, EQUAL_EACH
{$endif}
jnz @loop
mov eax, ecx
ret
nop // for @loop alignment
@loop: add eax, 16
{$ifdef HASAESNI}
pcmpistri xmm0, dqword[edx + eax], EQUAL_EACH // comparison result in ecx
{$else}
db $66, $0F, $3A, $63, $04, $10, EQUAL_EACH
{$endif}
jnz @loop
@ok: add eax, ecx
ret
@null: db $f3 // rep ret
end;
procedure YearToPChar(Y: PtrUInt; P: PUTF8Char);
{$ifdef FPC}nostackframe; assembler;{$endif}
asm // eax=Y, edx=P
push edx
mov ecx, eax
mov edx, 1374389535 // use power of two reciprocal to avoid division
mul edx
shr edx, 5 // now edx=Y div 100
movzx eax, word ptr[TwoDigitLookup + edx * 2]
imul edx, -200
movzx edx, word ptr[TwoDigitLookup + ecx * 2 + edx]
pop ecx
shl edx, 16
or eax, edx
mov [ecx], eax
end;
function Iso8601ToTimeLog(const S: RawByteString): TTimeLog;
{$ifdef FPC} nostackframe; assembler; {$endif} asm
xor ecx,ecx // ContainsNoTime=nil
test eax,eax // if s='' -> p=nil -> will return 0, whatever L value is
jz Iso8601ToTimeLogPUTF8Char
mov edx,[eax-4] // edx=L
@1: jmp Iso8601ToTimeLogPUTF8Char
end;
function UpperCopy(dest: PAnsiChar; const source: RawUTF8): PAnsiChar;
{$ifdef FPC} nostackframe; assembler; {$endif}
asm // eax=dest source=edx
test edx, edx
jz @z
push esi
mov esi, offset NormToUpperAnsi7
xor ecx, ecx
@1: mov cl, [edx]
inc edx
test cl, cl
mov cl, [esi + ecx]
jz @2
mov [eax], cl
inc eax
jmp @1
@2: pop esi
@z:
end;
function UpperCopyShort(dest: PAnsiChar; const source: shortstring): PAnsiChar;
{$ifdef FPC} nostackframe; assembler; {$endif}
asm // eax=dest source=edx
push esi
push ebx
movzx ebx, byte ptr[edx] // ebx = length(source)
xor ecx, ecx
test ebx, ebx
mov esi, offset NormToUpperAnsi7
jz @2 // source=''
inc edx
@1: mov cl, [edx]
inc edx
dec ebx
mov cl, [esi + ecx]
mov [eax], cl
lea eax, [eax + 1]
jnz @1
@2: pop ebx
pop esi
@z:
end;
function IdemPCharAndGetNextLine(var source: PUTF8Char; searchUp: PAnsiChar): boolean;
{$ifdef FPC} nostackframe; assembler; {$endif}
asm // eax=source edx=searchUp
push eax // save source var
mov eax, [eax] // eax=source
test eax, eax
jz @z
push eax
call IdemPChar
pop ecx // ecx=source
push eax // save result
@1: mov dl, [ecx] // while not (source^ in [#0,#10,#13]) do inc(source)
inc ecx
cmp dl, 13
ja @1
je @e
or dl, dl
jz @0
cmp dl, 10
jne @1
jmp @4
@e: cmp byte ptr[ecx], 10 // jump #13#10
jne @4
@3: inc ecx
@4: pop eax // restore result
pop edx // restore source var
mov [edx], ecx // update source var
ret
@0: xor ecx, ecx // set source=nil
jmp @4
@z: pop edx // ignore source var, result := false
end;
procedure crcblockNoSSE42(crc128, data128: PBlock128);
{$ifdef FPC} nostackframe; assembler; {$endif}
asm // Delphi is not efficient about compiling above pascal code
push ebp
push edi
push esi
mov ebp, eax // ebp=crc128 edi=data128
mov edi, edx
mov edx, dword ptr[eax]
mov ecx, dword ptr[eax + 4]
xor edx, dword ptr[edi]
xor ecx, dword ptr[edi + 4]
movzx esi, dl
mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3]
movzx esi, dh
shr edx, 16
xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2]
movzx esi, dl
xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1]
movzx esi, dh
xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0]
mov edx, dword ptr[ebp + 8]
xor edx, dword ptr[edi + 8]
mov dword ptr[ebp], eax
movzx esi, cl
mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3]
movzx esi, ch
shr ecx, 16
xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2]
movzx esi, cl
xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1]
movzx esi, ch
xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0]
mov dword ptr[ebp + 4], eax
mov ecx, dword ptr[ebp + 12]
xor ecx, dword ptr[edi + 12]
movzx esi, dl
mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3]
movzx esi, dh
shr edx, 16
xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2]
movzx esi, dl
xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1]
movzx esi, dh
xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0]
mov dword ptr[ebp + 8], eax
movzx esi, cl
mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3]
movzx esi, ch
shr ecx, 16
xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2]
movzx esi, cl
xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1]
movzx esi, ch
xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0]
mov dword ptr[ebp + 12], eax
pop esi
pop edi
pop ebp
end;
function crc32cfast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
{$ifdef FPC} nostackframe; assembler; {$endif}
asm // adapted from Aleksandr Sharahov code and Maxim Masiutin remarks
test edx, edx
jz @z
neg ecx
jz @z
not eax
push ebx
push ebp
lea ebp, [crc32ctab]
@head: test dl, 3
jz @align
movzx ebx, byte ptr[edx]
inc edx
xor bl, al
shr eax, 8
xor eax, dword ptr[ebx * 4 + ebp]
inc ecx
jnz @head
pop ebp
pop ebx
not eax
@z: ret
@align: sub edx, ecx
add ecx, 8
jg @done
push esi
push edi
mov edi, edx
@by8: mov edx, eax
mov ebx, [edi + ecx - 4]
xor edx, [edi + ecx - 8]
movzx esi, bl
mov eax, dword ptr[esi * 4 + ebp + 1024 * 3]
movzx esi, bh
xor eax, dword ptr[esi * 4 + ebp + 1024 * 2]
shr ebx, 16
movzx esi, bl
xor eax, dword ptr[esi * 4 + ebp + 1024 * 1]
movzx esi, bh
xor eax, dword ptr[esi * 4 + ebp + 1024 * 0]
movzx esi, dl
xor eax, dword ptr[esi * 4 + ebp + 1024 * 7]
movzx esi, dh
xor eax, dword ptr[esi * 4 + ebp + 1024 * 6]
shr edx, 16
movzx esi, dl
xor eax, dword ptr[esi * 4 + ebp + 1024 * 5]
movzx esi, dh
xor eax, dword ptr[esi * 4 + ebp + 1024 * 4]
add ecx, 8
jle @by8
mov edx, edi
pop edi
pop esi
@done: sub ecx, 8
jl @tail
pop ebp
pop ebx
not eax
ret
@tail: movzx ebx, byte[edx + ecx]
xor bl, al
shr eax, 8
xor eax, dword ptr[ebx * 4 + ebp]
inc ecx
jnz @tail
@e: pop ebp
pop ebx
not eax
end;
{$ifndef DELPHI5OROLDER}
const
CMP_RANGES = $44; // see https://msdn.microsoft.com/en-us/library/bb531425
function UpperCopy255BufSSE42(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar;
{$ifdef FPC} nostackframe; assembler; {$endif}
asm // eax=dest edx=source ecx=sourceLen
test ecx,ecx
jz @z
movups xmm1, dqword ptr [@az]
movups xmm3, dqword ptr [@bits]
cmp ecx, 16
ja @big
// optimize the common case of sourceLen<=16
movups xmm2, [edx]
{$ifdef HASAESNI}
pcmpistrm xmm1, xmm2, CMP_RANGES // find in range a-z, return mask in xmm0
{$else}
db $66, $0F, $3A, $62, $CA, CMP_RANGES
{$endif}
pand xmm0, xmm3
pxor xmm2, xmm0
movups [eax], xmm2
add eax, ecx
@z: ret
@big: push eax
cmp ecx, 240
jb @ok
mov ecx, 239
@ok: add [esp], ecx // save to return end position with the exact size
shr ecx, 4
sub edx, eax
inc ecx
@s: movups xmm2, [edx+eax]
{$ifdef HASAESNI}
pcmpistrm xmm1, xmm2, CMP_RANGES
{$else}
db $66, $0F, $3A, $62, $CA, CMP_RANGES
{$endif}
pand xmm0, xmm3
pxor xmm2, xmm0
movups [eax], xmm2
add eax, 16
dec ecx
jnz @s
pop eax
ret
@az: db 'azazazazazazazaz' // define range for upper case conversion
@bits: db ' ' // $20 = bit to change when changing case
end;
{$endif DELPHI5OROLDER}
function fnv32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal;
{$ifdef FPC} nostackframe; assembler; {$endif}
asm // eax=crc, edx=buf, ecx=len
push ebx
test edx, edx
jz @0
neg ecx
jz @0
sub edx, ecx
@1: movzx ebx, byte ptr[edx + ecx]
xor eax, ebx
imul eax, eax, 16777619
inc ecx
jnz @1
@0: pop ebx
end; // we tried an unrolled version, but it was slower on our Core i7!
function kr32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal;
{$ifdef FPC} nostackframe; assembler; {$endif}
asm // eax=crc, edx=buf, ecx=len
test ecx, ecx
push edi
push esi
push ebx
push ebp
jz @z
cmp ecx, 4
jb @s
@8: mov ebx, [edx] // unrolled version reading per dword
add edx, 4
mov esi, eax
movzx edi, bl
movzx ebp, bh
shr ebx, 16
shl eax, 5
sub eax, esi
add eax, edi
mov esi, eax
shl eax, 5
sub eax, esi
lea esi, [eax + ebp]
add eax, ebp
movzx edi, bl
movzx ebx, bh
shl eax, 5
sub eax, esi
lea ebp, [eax + edi]
add eax, edi
shl eax, 5
sub eax, ebp
add eax, ebx
cmp ecx, 8
lea ecx, [ecx - 4]
jae @8
test ecx, ecx
jz @z
@s: mov esi, eax
@1: shl eax, 5
movzx ebx, byte ptr[edx]
inc edx
sub eax, esi
lea esi, [eax + ebx]
add eax, ebx
dec ecx
jnz @1
@z: pop ebp
pop ebx
pop esi
pop edi
end;
function ToVarInt32(Value: PtrInt; Dest: PByte): PByte;
{$ifdef FPC} nostackframe; assembler; {$endif}
asm
test eax, eax
jnl @pos
neg eax
add eax, eax
jmp ToVarUInt32
@pos: jz @zer
lea eax, [eax * 2 - 1]
jmp ToVarUInt32
@zer: mov [edx], al
lea eax, [edx + 1]
end;
function ToVarUInt32(Value: PtrUInt; Dest: PByte): PByte;
{$ifdef FPC} nostackframe; assembler; {$endif}
asm
cmp eax, $7f
jbe @0
cmp eax, $00004000
jb @1
cmp eax, $00200000
jb @2
cmp eax, $10000000
jb @3
mov ecx, eax
shr eax, 7
and cl, $7f
or cl, $80
mov [edx], cl
inc edx
@3: mov ecx, eax
shr eax, 7
and cl, $7f
or cl, $80
mov [edx], cl
inc edx
@2: mov ecx, eax
shr eax, 7
and cl, $7f
or cl, $80
mov [edx], cl
inc edx
@1: mov ecx, eax
shr eax, 7
and cl, $7f
or cl, $80
mov [edx], cl
inc edx
@0: mov [edx], al
lea eax, [edx + 1]
end;
function CompareQWord(A, B: QWord): integer;
begin
{$ifdef FPC_OR_UNICODE} // recent compilers are able to generate correct code
result := ord(A>B)-ord(A<B);
{$else}
result := SortDynArrayQWord(A,B); // use correct x86 asm version below
{$endif}
end;
function SortDynArrayInteger(const A,B): integer;
{$ifdef FPC} nostackframe; assembler; {$endif} asm
mov ecx, [eax]
mov edx, [edx]
xor eax, eax
cmp ecx, edx
setl cl
setg al
movzx ecx, cl
sub eax, ecx
end;
function SortDynArrayCardinal(const A,B): integer;
{$ifdef FPC} nostackframe; assembler; {$endif} asm
mov ecx, [eax]
mov edx, [edx]
xor eax, eax
cmp ecx, edx
seta al
sbb eax,0
end;
function SortDynArrayPointer(const A,B): integer;
{$ifdef FPC} nostackframe; assembler; {$endif} asm
mov ecx, [eax]
mov edx, [edx]
xor eax, eax
cmp ecx, edx
seta al
sbb eax,0
end;
function SortDynArrayInt64(const A,B): integer;
{$ifdef FPC} nostackframe; assembler; {$endif}
asm // Delphi x86 compiler is not efficient at compiling Int64 comparisons
mov ecx, [eax]
mov eax, [eax + 4]
cmp eax, [edx + 4]
jnz @nz
cmp ecx, [edx]
jz @0
jnb @p
@n: mov eax, -1
ret
@0: xor eax, eax
ret
@nz: jl @n
@p: mov eax, 1
end;
function SortDynArrayQWord(const A,B): integer;
{$ifdef FPC} nostackframe; assembler; {$endif} asm
mov ecx, [eax]
mov eax, [eax + 4]
cmp eax, [edx + 4]
jnz @nz
cmp ecx, [edx]
jz @0
@nz: jnb @p
mov eax, -1
ret
@0: xor eax, eax
ret
@p: mov eax, 1
end;
function SortDynArrayRawByteString(const A,B): integer;
{$ifdef FPC} nostackframe; assembler; {$endif} asm
jmp SortDynArrayAnsiString
end;
function SortDynArrayAnsiString(const A,B): integer;
{$ifdef FPC} nostackframe; assembler; {$endif}
asm // x86 version optimized for AnsiString/RawUTF8/RawByteString 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] // ebx = length(A)-length(B)
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
mov eax, -1
ret
@n0: cmp eax, [edx - 4]
je @0
jnc @1
mov eax, -1
ret
@0: xor eax, eax
ret
@1: mov eax, 1
end;
function SortDynArrayAnsiStringI(const A,B): integer;
{$ifdef FPC} nostackframe; assembler; {$endif}
asm // avoid a call on the stack on x86 platform
mov eax, [eax]
mov edx, [edx]
jmp StrIComp
end;
function SortDynArrayPUTF8Char(const A,B): integer;
{$ifdef FPC} nostackframe; assembler; {$endif}
asm // avoid a call on the stack on x86 platform
mov eax, [eax]
mov edx, [edx]
jmp dword ptr[StrComp]
end;
function SortDynArrayDouble(const A,B): integer;
{$ifdef FPC} nostackframe; assembler; {$endif} asm
fld qword ptr[eax]
fcomp qword ptr[edx]
fstsw ax
sahf
jz @0
@nz: jnb @p
mov eax, -1
ret
@0: xor eax, eax
ret
@p: mov eax, 1
end;
function SortDynArraySingle(const A,B): integer;
{$ifdef FPC} nostackframe; assembler; {$endif} asm
fld dword ptr[eax]
fcomp dword ptr[edx]
fstsw ax
sahf
jz @0
@nz: jnb @p
mov eax, -1
ret
@0: xor eax, eax
ret
@p: mov eax, 1
end;
{$endif PUREPASCAL}
function PosExChar(Chr: AnsiChar; const Str: RawUTF8): PtrInt;
begin
if Str<>'' then
{$ifdef FPC} // will use fast FPC SSE version
result := IndexByte(pointer(Str)^,PStrLen(PtrUInt(Str)-_STRLEN)^,byte(chr))+1 else
{$else}
for result := 1 to PInteger(PtrInt(Str)-sizeof(Integer))^ do
if Str[result]=Chr then
exit;
{$endif FPC}
result := 0;
end;
function SplitRight(const Str: RawUTF8; SepChar: AnsiChar; LeftStr: PRawUTF8): RawUTF8;
var i: PtrInt;
begin
for i := length(Str) downto 1 do
if Str[i]=SepChar then begin
result := copy(Str,i+1,maxInt);
if LeftStr<>nil then
LeftStr^ := copy(Str,1,i-1);
exit;
end;
result := Str;
if LeftStr<>nil then
LeftStr^ := '';
end;
function SplitRights(const Str, SepChar: RawUTF8): RawUTF8;
var i, j, sep: PtrInt;
c: AnsiChar;
begin
sep := length(SepChar);
if sep > 0 then
if sep = 1 then
result := SplitRight(Str,SepChar[1]) else begin
for i := length(Str) downto 1 do begin
c := Str[i];
for j := 1 to sep do
if c=SepChar[j] then begin
result := copy(Str,i+1,maxInt);
exit;
end;
end;
end;
result := Str;
end;
function Split(const Str, SepStr: RawUTF8; StartPos: integer): RawUTF8;
var i: integer;
begin
{$ifdef FPC} // to use fast FPC SSE version
if (StartPos=1) and (length(SepStr)=1) then
i := PosExChar(SepStr[1],Str) else
{$endif FPC}
i := PosEx(SepStr,Str,StartPos);
if i>0 then
result := Copy(Str,StartPos,i-StartPos) else
if StartPos=1 then
result := Str else
result := Copy(Str,StartPos,maxInt);
end;
procedure Split(const Str, SepStr: RawUTF8; var LeftStr, RightStr: RawUTF8; ToUpperCase: boolean);
var i: integer;
tmp: RawUTF8; // may be called as Split(Str,SepStr,Str,RightStr)
begin
{$ifdef FPC} // to use fast FPC SSE version
if length(SepStr)=1 then
i := PosExChar(SepStr[1],Str) else
{$endif FPC}
i := PosEx(SepStr,Str);
if i=0 then begin
LeftStr := Str;
RightStr := '';
end else begin
tmp := copy(Str,1,i-1);
RightStr := copy(Str,i+length(SepStr),maxInt);
LeftStr := tmp;
end;
if ToUpperCase then begin
UpperCaseSelf(LeftStr);
UpperCaseSelf(RightStr);
end;
end;
function Split(const Str, SepStr: RawUTF8; var LeftStr: RawUTF8; ToUpperCase: boolean): RawUTF8;
begin
Split(Str,SepStr,LeftStr,result,ToUpperCase);
end;
function Split(const Str: RawUTF8; const SepStr: array of RawUTF8;
const DestPtr: array of PRawUTF8): PtrInt;
var s,i,j: PtrInt;
begin
j := 1;
result := 0;
s := 0;
if high(SepStr)>=0 then
while result<=high(DestPtr) do begin
i := PosEx(SepStr[s],Str,j);
if i=0 then begin
if DestPtr[result]<>nil then
DestPtr[result]^ := copy(Str,j,MaxInt);
inc(result);
break;
end;
if DestPtr[result]<>nil then
DestPtr[result]^ := copy(Str,j,i-j);
inc(result);
if s<high(SepStr) then
inc(s);
j := i+1;
end;
for i := result to high(DestPtr) do
if DestPtr[i]<>nil then
DestPtr[i]^ := '';
end;
function StringReplaceAllProcess(const S, OldPattern, NewPattern: RawUTF8;
found: integer): RawUTF8;
var oldlen,newlen,i,last,posCount,sharedlen: integer;
pos: TIntegerDynArray;
src,dst: PAnsiChar;
begin
oldlen := length(OldPattern);
newlen := length(NewPattern);
SetLength(pos,64);
pos[0] := found;
posCount := 1;
repeat
found := PosEx(OldPattern,S,found+oldlen);
if found=0 then
break;
AddInteger(pos,posCount,found);
until false;
FastSetString(result,nil,Length(S)+(newlen-oldlen)*posCount);
last := 1;
src := pointer(s);
dst := pointer(result);
for i := 0 to posCount-1 do begin
sharedlen := pos[i]-last;
MoveFast(src^,dst^,sharedlen);
inc(src,sharedlen+oldlen);
inc(dst,sharedlen);
if newlen>0 then begin
MoveSmall(pointer(NewPattern),dst,newlen);
inc(dst,newlen);
end;
last := pos[i]+oldlen;
end;
MoveFast(src^,dst^,length(S)-last+1);
end;
function StringReplaceAll(const S, OldPattern, NewPattern: RawUTF8): RawUTF8;
var found: integer;
begin
if (S='') or (OldPattern='') or (OldPattern=NewPattern) then
result := S else begin
found := PosEx(OldPattern,S,1); // our PosEx() is faster than Pos()
if found=0 then
result := S else
result := StringReplaceAllProcess(S,OldPattern,NewPattern,found);
end;
end;
function StringReplaceAll(const S: RawUTF8; const OldNewPatternPairs: array of RawUTF8): RawUTF8;
var n,i: integer;
begin
result := S;
n := high(OldNewPatternPairs);
if (n>0) and (n and 1=1) then
for i := 0 to n shr 1 do
result := StringReplaceAll(result,OldNewPatternPairs[i*2],OldNewPatternPairs[i*2+1]);
end;
function StringReplaceTabs(const Source,TabText: RawUTF8): RawUTF8;
procedure Process(S,D,T: PAnsiChar; TLen: integer);
begin
repeat
if S^=#0 then
break else
if S^<>#9 then begin
D^ := S^;
inc(D);
inc(S);
end else begin
if TLen>0 then begin
MoveSmall(T,D,TLen);
inc(D,TLen);
end;
inc(S);
end;
until false;
end;
var L,i,n,ttl: PtrInt;
begin
ttl := length(TabText);
L := Length(Source);
n := 0;
if ttl<>0 then
for i := 1 to L do
if Source[i]=#9 then
inc(n);
if n=0 then begin
result := Source;
exit;
end;
FastSetString(result,nil,L+n*pred(ttl));
Process(pointer(Source),pointer(result),pointer(TabText),ttl);
end;
function strspnpas(s,accept: pointer): integer;
var p: PCardinal;
c: AnsiChar;
d: cardinal;
begin // returns size of initial segment of s which are in accept
result := 0;
repeat
c := PAnsiChar(s)[result];
if c=#0 then
break;
p := accept;
repeat // stop as soon as we find any character not from accept
d := p^;
inc(p);
if AnsiChar(d)=c then
break else
if AnsiChar(d)=#0 then
exit;
d := d shr 8;
if AnsiChar(d)=c then
break else
if AnsiChar(d)=#0 then
exit;
d := d shr 8;
if AnsiChar(d)=c then
break else
if AnsiChar(d)=#0 then
exit;
d := d shr 8;
if AnsiChar(d)=c then
break else
if AnsiChar(d)=#0 then
exit;
until false;
inc(result);
until false;
end;
function strcspnpas(s,reject: pointer): integer;
var p: PCardinal;
c: AnsiChar;
d: cardinal;
begin // returns size of initial segment of s which are not in reject
result := 0;
repeat
c := PAnsiChar(s)[result];
if c=#0 then
break;
p := reject;
repeat // stop as soon as we find any character from reject
d := p^;
inc(p);
if AnsiChar(d)=c then
exit else
if AnsiChar(d)=#0 then
break;
d := d shr 8;
if AnsiChar(d)=c then
exit else
if AnsiChar(d)=#0 then
break;
d := d shr 8;
if AnsiChar(d)=c then
exit else
if AnsiChar(d)=#0 then
break;
d := d shr 8;
if AnsiChar(d)=c then
exit else
if AnsiChar(d)=#0 then
break;
until false;
inc(result);
until false;
end;
{$ifndef ABSOLUTEPASCAL}
{$ifdef CPUINTEL}
{$ifdef CPUX64} // inspired by Agner Fog's strspn64.asm
function strcspnsse42(s,reject: pointer): integer;
{$ifdef FPC}nostackframe; assembler; asm {$else}
asm .noframe // rcx=s, rdx=reject (Linux: rdi,rsi)
{$endif FPC}
{$ifdef win64}
push rdi
push rsi
mov rdi, rcx
mov rsi, rdx
{$endif}mov r8, rsi
xor ecx, ecx
@1: movups xmm2, [rdi]
movups xmm1, [rsi]
{$ifdef HASAESNI}
pcmpistrm xmm1, xmm2, $30 // find in set, invert valid bits, return bit mask in xmm0
{$else}
db $66,$0F,$3A,$62,$CA,$30
{$endif}
movd eax, xmm0
jns @5
@2: cmp eax, 65535
jne @3
add rdi, 16 // first 16 chars matched, continue with next 16 chars
add rcx, 16
jmp @1
@3: not eax
bsf eax, eax
add rax, rcx
{$ifdef win64}
pop rsi
pop rdi
{$endif}ret
@4: and eax, edx // accumulate matches
@5: add rsi, 16 // the set is more than 16 bytes
movups xmm1, [rsi]
{$ifdef HASAESNI}
pcmpistrm xmm1, xmm2, $30
{$else}
db $66,$0F,$3A,$62,$CA,$30
{$endif}
movd edx, xmm0
jns @4
mov rsi, r8 // restore set pointer
and eax, edx // accumulate matches
cmp eax, 65535
jne @3
add rdi, 16
add rcx, 16
jmp @1
end;
function strspnsse42(s,accept: pointer): integer;
{$ifdef FPC}nostackframe; assembler; asm {$else}
asm .noframe // rcx=s, rdx=accept (Linux: rdi,rsi)
{$endif FPC}
{$ifdef win64}
push rdi
push rsi
mov rdi, rcx
mov rsi, rdx
{$endif}mov r8, rsi
xor ecx, ecx
@1: movups xmm2, [rdi]
movups xmm1, [rsi]
{$ifdef HASAESNI}
pcmpistrm xmm1, xmm2, $00 // find in set, return bit mask in xmm0
{$else}
db $66,$0F,$3A,$62,$CA,$00
{$endif}
movd eax, xmm0
jns @5
@2: cmp eax, 65535
jne @3
add rdi, 16 // first 16 chars matched, continue with next 16 chars
add rcx, 16
jmp @1
@3: not eax
bsf eax, eax
add rax, rcx
{$ifdef win64}
pop rsi
pop rdi
{$endif}ret
@4: or eax, edx // accumulate matches
@5: add rsi, 16 // the set is more than 16 bytes
movups xmm1, [rsi]
{$ifdef HASAESNI}
pcmpistrm xmm1, xmm2, $00
{$else}
db $66,$0F,$3A,$62,$CA,$00
{$endif}
movd edx, xmm0
jns @4
mov rsi, r8 // restore set pointer
or eax, edx // accumulate matches
cmp eax, 65535
jne @3
add rdi, 16 // first 16 chars matched, continue with next 16 chars
add rcx, 16
jmp @1
end;
{$endif CPUX64}
{$ifdef CPUX86}
function strcspnsse42(s,reject: pointer): integer; {$ifdef FPC} nostackframe; assembler; {$endif}
asm // eax=s, edx=reject
push edi
push esi
push ebx
mov edi, eax
mov esi, edx
mov ebx, esi
xor ecx, ecx
@1: {$ifdef HASAESNI}
movups xmm2, dqword [edi]
movups xmm1, dqword [esi]
pcmpistrm xmm1, xmm2, $30 // find in set, invert valid bits, return bit mask in xmm0
movd eax, xmm0
{$else}
db $F3,$0F,$6F,$17
db $F3,$0F,$6F,$0E
db $66,$0F,$3A,$62,$CA,$30
db $66,$0F,$7E,$C0
{$endif}
jns @5
@2: cmp eax, 65535
jne @3
add edi, 16 // first 16 chars matched, continue with next 16 chars
add ecx, 16
jmp @1
@3: not eax
bsf eax, eax
add eax, ecx
pop ebx
pop esi
pop edi
ret
@4: and eax, edx // accumulate matches
@5: add esi, 16 // the set is more than 16 bytes
{$ifdef HASAESNI}
movups xmm1, [esi]
pcmpistrm xmm1, xmm2, $30
movd edx, xmm0
{$else}
db $F3,$0F,$6F,$0E
db $66,$0F,$3A,$62,$CA,$30
db $66,$0F,$7E,$C2
{$endif}
jns @4
mov esi, ebx // restore set pointer
and eax, edx // accumulate matches
cmp eax, 65535
jne @3
add edi, 16 // first 16 chars matched, continue with next 16 chars
add ecx, 16
jmp @1
end;
function strspnsse42(s,accept: pointer): integer; {$ifdef FPC} nostackframe; assembler; {$endif}
asm // eax=s, edx=accept
push edi
push esi
push ebx
mov edi, eax
mov esi, edx
mov ebx, esi
xor ecx, ecx
@1: {$ifdef HASAESNI}
movups xmm2, dqword [edi]
movups xmm1, dqword [esi]
pcmpistrm xmm1, xmm2, $00 // find in set, return bit mask in xmm0
movd eax, xmm0
{$else}
db $F3,$0F,$6F,$17
db $F3,$0F,$6F,$0E
db $66,$0F,$3A,$62,$CA,$00
db $66,$0F,$7E,$C0
{$endif}
jns @5
@2: cmp eax, 65535
jne @3
add edi, 16 // first 16 chars matched, continue with next 16 chars
add ecx, 16
jmp @1
@3: not eax
bsf eax, eax
add eax, ecx
pop ebx
pop esi
pop edi
ret
@4: or eax, edx // accumulate matches
@5: add esi, 16 // the set is more than 16 bytes
{$ifdef HASAESNI}
movups xmm1, [esi]
pcmpistrm xmm1, xmm2, $00
movd edx, xmm0
{$else}
db $F3,$0F,$6F,$0E
db $66,$0F,$3A,$62,$CA,$00
db $66,$0F,$7E,$C2
{$endif}
jns @4
mov esi, ebx // restore set pointer
or eax, edx // accumulate matches
cmp eax, 65535
jne @3
add edi, 16 // first 16 chars matched, continue with next 16 chars
add ecx, 16
jmp @1
end;
{$ifndef DELPHI5OROLDER}
function StrLenSSE2(S: pointer): PtrInt; {$ifdef FPC} nostackframe; assembler; {$endif}
asm // from GPL strlen32.asm by Agner Fog - www.agner.org/optimize
mov ecx, eax // copy pointer
test eax, eax
jz @null // returns 0 if S=nil
push eax // save start address
pxor xmm0, xmm0 // set to zero
and ecx, 15 // lower 4 bits indicate misalignment
and eax, -16 // align pointer by 16
// will never read outside a memory page boundary, so won't trigger GPF
movaps xmm1, [eax] // read from nearest preceding boundary
pcmpeqb xmm1, xmm0 // compare 16 bytes with zero
pmovmskb edx, xmm1 // get one bit for each byte result
shr edx, cl // shift out false bits
shl edx, cl // shift back again
bsf edx, edx // find first 1-bit
jnz @A200 // found
// Main loop, search 16 bytes at a time
@A100: add eax, 10H // increment pointer by 16
movaps xmm1, [eax] // read 16 bytes aligned
pcmpeqb xmm1, xmm0 // compare 16 bytes with zero
pmovmskb edx, xmm1 // get one bit for each byte result
bsf edx, edx // find first 1-bit
// (moving the bsf out of the loop and using test here would be faster
// for long strings on old processors, but we are assuming that most
// strings are short, and newer processors have higher priority)
jz @A100 // loop if not found
@A200: // Zero-byte found. Compute string length
pop ecx // restore start address
sub eax, ecx // subtract start address
add eax, edx // add byte index
@null:
end;
{$endif DELPHI5OROLDER}
{$endif CPUX86}
{$endif CPUINTEL}
{$endif ABSOLUTEPASCAL}
function IdemPropName(const P1,P2: shortstring): boolean;
begin
if P1[0]=P2[0] then
result := IdemPropNameUSameLen(@P1[1],@P2[1],ord(P2[0])) else
result := false;
end;
function IdemPropName(const P1: shortstring; P2: PUTF8Char; P2Len: PtrInt): boolean;
begin
if ord(P1[0])=P2Len then
result := IdemPropNameUSameLen(@P1[1],P2,P2Len) else
result := false;
end;
function IdemPropName(P1,P2: PUTF8Char; P1Len,P2Len: PtrInt): boolean;
begin
if P1Len=P2Len then
result := IdemPropNameUSameLen(P1,P2,P2Len) else
result := false;
end;
function IdemPropNameU(const P1: RawUTF8; P2: PUTF8Char; P2Len: PtrInt): boolean;
begin
if length(P1)=P2Len then
result := IdemPropNameUSameLen(pointer(P1),P2,P2Len) else
result := false;
end;
function ToText(os: TOperatingSystem): PShortString;
begin
result := GetEnumName(TypeInfo(TOperatingSystem),ord(os));
end;
function ToText(const osv: TOperatingSystemVersion): ShortString;
begin
if osv.os=osWindows then
FormatShort('Windows %', [WINDOWS_NAME[osv.win]], result) else
TrimLeftLowerCaseToShort(ToText(osv.os),result);
end;
function ToTextOS(osint32: integer): RawUTF8;
var osv: TOperatingSystemVersion absolute osint32;
ost: ShortString;
begin
ost := ToText(osv);
if (osv.os>=osLinux) and (osv.utsrelease[2]<>0) then
result := FormatUTF8('% %.%.%',[ost,osv.utsrelease[2],osv.utsrelease[1],osv.utsrelease[0]]) else
result := ShortStringToUTF8(ost);
end;
{$ifdef MSWINDOWS}
procedure FileTimeToInt64(const FT: TFileTime; out I64: Int64);
begin
{$ifdef CPU64}
PInt64Rec(@I64)^.Lo := FT.dwLowDateTime;
PInt64Rec(@I64)^.Hi := FT.dwHighDateTime;
{$else}
I64 := PInt64(@FT)^;
{$endif}
end;
const
// lpMinimumApplicationAddress retrieved from Windows is very low $10000
// - i.e. maximum number of ID per table would be 65536 in TSQLRecord.GetID
// - so we'll force an higher and almost "safe" value as 1,048,576
// (real value from runnning Windows is greater than $400000)
MIN_PTR_VALUE = $100000;
// see http://msdn.microsoft.com/en-us/library/ms724833(v=vs.85).aspx
VER_NT_WORKSTATION = 1;
VER_NT_DOMAIN_CONTROLLER = 2;
VER_NT_SERVER = 3;
SM_SERVERR2 = 89;
PROCESSOR_ARCHITECTURE_AMD64 = 9;
{$ifndef UNICODE}
function GetVersionEx(var lpVersionInformation: TOSVersionInfoEx): BOOL; stdcall;
external kernel32 name 'GetVersionExA';
{$endif}
threadvar // mandatory: GetTickCount seems per-thread on XP :(
LastTickXP: TQWordRec;
function GetTickCount64ForXP: Int64; stdcall;
var t32: cardinal;
p: PQWordRec;
begin // warning: GetSystemTimeAsFileTime() is fast, but not monotonic!
t32 := Windows.GetTickCount;
p := @LastTickXP;
if t32<p^.L then
inc(p^.H); // wrap-up overflow after 49 days
p^.L := t32;
result := p^.V;
end; // warning: FPC's GetTickCount64 doesn't handle 49 days wrap :(
{$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;
{ TWinRegistry }
function TWinRegistry.ReadOpen(root: HKEY; const keyname: RawUTF8;
closefirst: boolean): boolean;
var tmp: TSynTempBuffer;
begin
if closefirst then
Close;
tmp.Init(length(keyname)*2);
UTF8ToWideChar(tmp.buf,pointer(keyname));
key := 0;
result := RegOpenKeyExW(root,tmp.buf,0,KEY_READ,key)=0;
tmp.Done;
end;
procedure TWinRegistry.Close;
begin
if key<>0 then
RegCloseKey(key);
end;
function TWinRegistry.ReadString(const entry: SynUnicode; andtrim: boolean): RawUTF8;
var rtype, rsize: DWORD;
tmp: TSynTempBuffer;
begin
result := '';
if RegQueryValueExW(key,pointer(entry),nil,@rtype,nil,@rsize)<>0 then
exit;
tmp.Init(rsize);
if RegQueryValueExW(key,pointer(entry),nil,nil,tmp.buf,@rsize)=0 then begin
case rtype of
REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ:
RawUnicodeToUtf8(tmp.buf,StrLenW(tmp.buf),result);
end;
if andtrim then
result := Trim(result);
end;
tmp.Done;
end;
function TWinRegistry.ReadData(const entry: SynUnicode): RawByteString;
var rtype, rsize: DWORD;
begin
result := '';
if RegQueryValueExW(key,pointer(entry),nil,@rtype,nil,@rsize)<>0 then
exit;
SetLength(result,rsize);
if RegQueryValueExW(key,pointer(entry),nil,nil,pointer(result),@rsize)<>0 then
result := '';
end;
function TWinRegistry.ReadDword(const entry: SynUnicode): cardinal;
var rsize: DWORD;
begin
rsize := 4;
if RegQueryValueExW(key,pointer(entry),nil,nil,@result,@rsize)<>0 then
result := 0;
end;
function TWinRegistry.ReadQword(const entry: SynUnicode): QWord;
var rsize: DWORD;
begin
rsize := 8;
if RegQueryValueExW(key,pointer(entry),nil,nil,@result,@rsize)<>0 then
result := 0;
end;
function TWinRegistry.ReadEnumEntries: TRawUTF8DynArray;
var count,maxlen,i,len: DWORD;
tmp: TSynTempBuffer;
begin
result := nil;
if (RegQueryInfoKeyW(key,nil,nil,nil,@count,@maxlen,nil,nil,nil,nil,nil,nil)<>0) or
(count=0) then
exit;
SetLength(result,count);
inc(maxlen);
tmp.Init(maxlen*3);
for i := 0 to count-1 do begin
len := maxlen;
if RegEnumKeyExW(key,i,tmp.buf,len,nil,nil,nil,nil)=0 then
RawUnicodeToUtf8(tmp.buf,len,result[i]);
end;
tmp.Done;
end;
procedure RetrieveSystemInfo;
var
IsWow64Process: function(Handle: THandle; var Res: BOOL): BOOL; stdcall;
GetNativeSystemInfo: procedure(var SystemInfo: TSystemInfo); stdcall;
wine_get_version: function: PAnsiChar; stdcall;
Res: BOOL;
h: THandle;
P: pointer;
Vers: TWindowsVersion;
cpu, manuf, prod, prodver: RawUTF8;
reg: TWinRegistry;
begin
h := GetModuleHandle(kernel32);
GetTickCount64 := GetProcAddress(h,'GetTickCount64');
if not Assigned(GetTickCount64) then // WinXP+
GetTickCount64 := @GetTickCount64ForXP;
GetSystemTimePreciseAsFileTime := GetProcAddress(h,'GetSystemTimePreciseAsFileTime');
if not Assigned(GetSystemTimePreciseAsFileTime) then // Win8+
GetSystemTimePreciseAsFileTime := @GetSystemTimeAsFileTime;
IsWow64Process := GetProcAddress(h,'IsWow64Process');
Res := false;
IsWow64 := Assigned(IsWow64Process) and
IsWow64Process(GetCurrentProcess,Res) and Res;
FillcharFast(SystemInfo,SizeOf(SystemInfo),0);
if IsWow64 then // see http://msdn.microsoft.com/en-us/library/ms724381(v=VS.85).aspx
GetNativeSystemInfo := GetProcAddress(h,'GetNativeSystemInfo') else
@GetNativeSystemInfo := nil;
if Assigned(GetNativeSystemInfo) then
GetNativeSystemInfo(SystemInfo) else
Windows.GetSystemInfo(SystemInfo);
GetMem(P,10); // ensure that using MIN_PTR_VALUE won't break anything
if (PtrUInt(P)>MIN_PTR_VALUE) and
(PtrUInt(SystemInfo.lpMinimumApplicationAddress)<=MIN_PTR_VALUE) then
PtrUInt(SystemInfo.lpMinimumApplicationAddress) := MIN_PTR_VALUE;
Freemem(P);
OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo);
GetVersionEx(OSVersionInfo);
Vers := wUnknown;
with OSVersionInfo do
// see https://msdn.microsoft.com/en-us/library/windows/desktop/ms724833
case dwMajorVersion of
5: case dwMinorVersion of
0: Vers := w2000;
1: Vers := wXP;
2: if (wProductType=VER_NT_WORKSTATION) and
(SystemInfo.wProcessorArchitecture=PROCESSOR_ARCHITECTURE_AMD64) then
Vers := wXP_64 else
if GetSystemMetrics(SM_SERVERR2)=0 then
Vers := wServer2003 else
Vers := wServer2003_R2;
end;
6: case dwMinorVersion of
0: Vers := wVista;
1: Vers := wSeven;
2: Vers := wEight;
3: Vers := wEightOne;
4: Vers := wTen;
end;
10: Vers := wTen;
end;
if Vers>=wVista then begin
if OSVersionInfo.wProductType<>VER_NT_WORKSTATION then begin // Server edition
inc(Vers,2); // e.g. wEight -> wServer2012
if (Vers=wServer2016) and (OSVersionInfo.dwBuildNumber>=17763) then
Vers := wServer2019_64; // https://stackoverflow.com/q/53393150
end else if (Vers=wTen) and (OSVersionInfo.dwBuildNumber>=22000) then
Vers := wEleven; // waiting for an official mean of Windows 11 identification
if (SystemInfo.wProcessorArchitecture=PROCESSOR_ARCHITECTURE_AMD64) and
(Vers<wServer2019_64) then
inc(Vers); // e.g. wEight -> wEight64
end;
OSVersion := Vers;
with OSVersionInfo do
if wServicePackMajor=0 then
FormatUTF8('Windows % (%.%.%)',[WINDOWS_NAME[Vers],
dwMajorVersion,dwMinorVersion,dwBuildNumber],OSVersionText) else
FormatUTF8('Windows % SP% (%.%.%)',[WINDOWS_NAME[Vers],wServicePackMajor,
dwMajorVersion,dwMinorVersion,dwBuildNumber],OSVersionText);
OSVersionInt32 := (integer(Vers) shl 8)+ord(osWindows);
if reg.ReadOpen(HKEY_LOCAL_MACHINE,'Hardware\Description\System\CentralProcessor\0') then begin
cpu := reg.ReadString('ProcessorNameString');
if cpu='' then
cpu := reg.ReadString('Identifier');
end;
if reg.ReadOpen(HKEY_LOCAL_MACHINE,'Hardware\Description\System\BIOS',true) then begin
manuf := reg.ReadString('SystemManufacturer');
if manuf<>'' then
manuf := manuf+' ';
prod := reg.ReadString('SystemProductName');
prodver := reg.ReadString('SystemVersion');
if prodver='' then
prodver := reg.ReadString('BIOSVersion');
end;
if (prod='') or (prodver='') then begin
if reg.ReadOpen(HKEY_LOCAL_MACHINE,'Hardware\Description\System',true) then begin
if prod='' then
prod := reg.ReadString('SystemBiosVersion');
if prodver='' then
prodver := reg.ReadString('VideoBiosVersion');
end;
end;
reg.Close;
if prodver<>'' then
FormatUTF8('%% %',[manuf,prod,prodver],BiosInfoText) else
FormatUTF8('%%',[manuf,prod],BiosInfoText);
if cpu='' then
cpu := StringToUTF8(GetEnvironmentVariable('PROCESSOR_IDENTIFIER'));
cpu := Trim(cpu);
FormatUTF8('% x % ('+CPU_ARCH_TEXT+')',[SystemInfo.dwNumberOfProcessors,cpu],CpuInfoText);
h := LoadLibrary('ntdll.dll');
if h>0 then begin
wine_get_version := GetProcAddress(h,'wine_get_version');
if Assigned(wine_get_version) then
OSVersionInfoEx := trim('Wine '+trim(wine_get_version));
FreeLibrary(h);
end;
if OSVersionInfoEx<>'' then
OSVersionText := FormatUTF8('% - %', [OSVersionText,OSVersionInfoEx]);
end;
{$else}
{$ifndef BSD}
procedure SetLinuxDistrib(const release: RawUTF8);
var
distrib: TOperatingSystem;
dist: RawUTF8;
begin
for distrib := osArch to high(distrib) do begin
dist := UpperCase(TrimLeftLowerCaseShort(ToText(distrib)));
if PosI(pointer(dist),release)>0 then begin
OS_KIND := distrib;
break;
end;
end;
end;
{$endif BSD}
procedure RetrieveSystemInfo;
var modname, beg: PUTF8Char;
{$ifdef BSD}
temp: shortstring;
{$else}
cpuinfo: PUTF8Char;
proccpuinfo,prod,prodver,release,dist: RawUTF8;
SR: TSearchRec;
{$endif BSD}
begin
modname := nil;
{$ifdef BSD}
fpuname(SystemInfo.uts);
SystemInfo.dwNumberOfProcessors := fpsysctlhwint(HW_NCPU);
Utf8ToRawUTF8(fpsysctlhwstr(HW_MACHINE,temp),BiosInfoText);
modname := fpsysctlhwstr(HW_MODEL,temp);
with SystemInfo.uts do
FormatUTF8('%-% %',[sysname,release,version],OSVersionText);
{$else}
{$ifdef KYLIX3}
uname(SystemInfo.uts);
{$else}
fpuname(SystemInfo.uts);
{$endif KYLIX3}
prod := Trim(StringFromFile('/sys/class/dmi/id/product_name',true));
if prod<>'' then begin
prodver := Trim(StringFromFile('/sys/class/dmi/id/product_version',true));
if prodver<>'' then
FormatUTF8('% %',[prod,prodver],BiosInfoText) else
BiosInfoText := prod;
end;
SystemInfo.dwNumberOfProcessors := 0;
proccpuinfo := StringFromFile('/proc/cpuinfo',true);
cpuinfo := pointer(proccpuinfo);
while cpuinfo<>nil do begin
beg := cpuinfo;
cpuinfo := GotoNextLine(cpuinfo);
if IdemPChar(beg,'PROCESSOR') then
if beg^='P' then
modname := beg else // Processor : ARMv7
inc(SystemInfo.dwNumberOfProcessors) else // processor : 0
if IdemPChar(beg,'MODEL NAME') then
modname := beg;
end;
modname := PosChar(modname,':');
if modname<>nil then
modname := GotoNextNotSpace(modname+1);
FindNameValue(StringFromFile('/etc/os-release'),'PRETTY_NAME=',release);
if (release<>'') and (release[1]='"') then
release := copy(release,2,length(release)-2);
release := trim(release);
if release='' then
if FindNameValue(StringFromFile('/etc/lsb-release'),'DISTRIB_DESCRIPTION=',release) and
(release<>'') and (release[1]='"') then
release := copy(release,2,length(release)-2);
if (release='') and (FindFirst('/etc/*-release',faAnyFile,SR)=0) then begin
release := StringToUTF8(SR.Name); // 'redhat-release' 'SuSE-release'
if IdemPChar(pointer(release),'LSB-') and (FindNext(SR)=0) then
release := StringToUTF8(SR.Name);
release := split(release,'-');
dist := split(trim(StringFromFile('/etc/'+SR.Name)),#10);
if (dist<>'') and (PosExChar('=',dist)=0) and (PosExChar(' ',dist)>0) then
SetLinuxDistrib(dist) // e.g. 'Red Hat Enterprise Linux Server release 6.7 (Santiago)'
else
dist := '';
FindClose(SR);
end;
if (release<>'') and (OS_KIND=osLinux) then begin
SetLinuxDistrib(release);
if (OS_KIND=osLinux) and (dist<>'') then begin
SetLinuxDistrib(dist);
release := dist;
end;
if (OS_KIND=osLinux) and ((PosEx('RH',release)>0) or (PosEx('Red Hat',release)>0)) then
OS_KIND := osRedHat;
end;
SystemInfo.release := release;
{$endif BSD}
OSVersionInt32 := {$ifdef FPC}integer(KernelRevision shl 8)+{$endif}ord(OS_KIND);
with SystemInfo.uts do
FormatUTF8('% %',[sysname,release],OSVersionText);
if SystemInfo.release<>'' then
OSVersionText := FormatUTF8('% - %',[SystemInfo.release,OSVersionText]);
{$ifdef Android}
OSVersionText := 'Android ('+OSVersionText+')';
{$endif}
if (SystemInfo.dwNumberOfProcessors>0) and (modname<>nil) then begin
beg := modname;
while not (ord(modname^) in [0,10,13]) do begin
if modname^<' ' then
modname^ := ' ';
inc(modname);
end;
modname^ := #0;
FormatUTF8('% x % ('+CPU_ARCH_TEXT+')',[SystemInfo.dwNumberOfProcessors,beg],CpuInfoText);
end;
if CpuInfoText='' then
CpuInfoText := CPU_ARCH_TEXT;
end;
{$ifdef KYLIX3}
function FileOpen(const FileName: string; Mode: LongWord): Integer;
const
SHAREMODE: array[0..fmShareDenyNone shr 4] of Byte = (
0, // No share mode specified
F_WRLCK, // fmShareExclusive
F_RDLCK, // fmShareDenyWrite
0); // fmShareDenyNone
var FileHandle, Tvar: Integer;
LockVar: TFlock;
smode: Byte;
begin
result := -1;
if FileExists(FileName) and
((Mode and 3)<=fmOpenReadWrite) and ((Mode and $F0)<=fmShareDenyNone) then begin
FileHandle := open64(pointer(FileName),(Mode and 3),FileAccessRights);
if FileHandle=-1 then
exit;
smode := Mode and $F0 shr 4;
if SHAREMODE[smode]<>0 then begin
with LockVar do begin
l_whence := SEEK_SET;
l_start := 0;
l_len := 0;
l_type := SHAREMODE[smode];
end;
Tvar := fcntl(FileHandle,F_SETLK,LockVar);
if Tvar=-1 then begin
__close(FileHandle);
exit;
end;
end;
result := FileHandle;
end;
end;
function GetTickCount64: Int64;
begin
result := SynKylix.GetTickCount64;
end;
{$endif KYLIX3}
{$ifdef FPC}
function GetTickCount64: Int64;
begin
result := SynFPCLinux.GetTickCount64;
end;
{$endif FPC}
{$endif MSWINDOWS}
function FileOpenSequentialRead(const FileName: string): Integer;
begin
{$ifdef MSWINDOWS}
if OSVersion>=wVista then // don't use the flag on XP
result := CreateFile(pointer(FileName),GENERIC_READ,
FILE_SHARE_READ or FILE_SHARE_WRITE,nil, // same as fmShareDenyNone
OPEN_EXISTING,FILE_FLAG_SEQUENTIAL_SCAN,0) else
result := FileOpen(FileName,fmOpenRead or fmShareDenyNone);
{$else}
// SysUtils.FileOpen = fpOpen + fpFlock - assuming FileName is UTF-8
result := fpOpen(pointer(FileName), O_RDONLY);
{$endif MSWINDOWS}
end;
type
{$ifdef DELPHI5ORFPC} // TFileStream doesn't have per-handle constructor like Delphi
TFileStreamFromHandle = class(THandleStream)
public
destructor Destroy; override;
end;
destructor TFileStreamFromHandle.Destroy;
begin
FileClose(Handle); // otherwise file is still opened
end;
{$else}
TFileStreamFromHandle = TFileStream;
{$endif DELPHI5ORFPC}
function FileStreamSequentialRead(const FileName: string): THandleStream;
begin
result := TFileStreamFromHandle.Create(FileOpenSequentialRead(FileName));
end;
function Elapsed(var PreviousTix: Int64; Interval: Integer): Boolean;
var now: Int64;
begin
if Interval<=0 then
result := false else begin
now := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64;
if now-PreviousTix>Interval then begin
PreviousTix := now;
result := true;
end else
result := false;
end;
end;
function StrCntDecFree(var refcnt: TStrCnt): boolean;
{$ifdef CPUINTEL} {$ifdef FPC}nostackframe; assembler; {$endif}
asm {$ifdef CPU64DELPHI} .noframe {$endif}
{$ifdef STRCNT32}
lock dec dword ptr[refcnt]
{$else}
lock dec qword ptr[refcnt]
{$endif STRCNT32}
setbe al
end; // we don't check for ismultithread global since lock is cheap on new CPUs
{$else}
begin // fallback to RTL asm e.g. for ARM
{$ifdef STRCNT32}
result := InterLockedDecrement(refcnt)<=0;
{$else}
result := InterLockedDecrement64(refcnt)<=0;
{$endif STRCNT32}
end;
{$endif CPUINTEL}
function DACntDecFree(var refcnt: TDACnt): boolean;
{$ifdef CPUINTEL} {$ifdef FPC}nostackframe; assembler; {$endif}
asm {$ifdef CPU64DELPHI} .noframe {$endif}
{$ifdef DACNT32}
lock dec dword ptr[refcnt]
{$else}
lock dec qword ptr[refcnt]
{$endif DACNT32}
setbe al
end; // we don't check for ismultithread global since lock is cheap on new CPUs
{$else}
begin // fallback to RTL asm e.g. for ARM
{$ifdef DACNT32}
result := InterLockedDecrement(refcnt)<=0;
{$else}
result := InterLockedDecrement64(refcnt)<=0;
{$endif DACNT32}
end;
{$endif CPUINTEL}
{$ifndef FPC} // FPC has its built-in InterlockedIncrement/InterlockedDecrement
{$ifdef PUREPASCAL}
function InterlockedIncrement(var I: Integer): Integer;
begin
{$ifdef MSWINDOWS} // AtomicIncrement() may not be available e.g. on Delphi XE2
result := Windows.InterlockedIncrement(I);
{$else}
result := AtomicIncrement(I);
{$endif}
end;
function InterlockedDecrement(var I: Integer): Integer;
begin
{$ifdef MSWINDOWS} // AtomicDecrement() may not be available e.g. on Delphi XE2
result := Windows.InterlockedDecrement(I);
{$else}
result := AtomicDecrement(I);
{$endif}
end;
{$else}
function InterlockedIncrement(var I: Integer): Integer;
asm
mov edx, 1
xchg eax, edx
lock xadd [edx], eax
inc eax
end;
function InterlockedDecrement(var I: Integer): Integer;
asm
mov edx, -1
xchg eax, edx
lock xadd [edx], eax
dec eax
end;
{$endif}
{$endif FPC}
function GetHighUTF8UCS4(var U: PUTF8Char): PtrUInt;
var extra,i: PtrInt;
c: PtrUInt;
begin
result := 0;
c := byte(U^); // here U^>=#80
inc(U);
extra := UTF8_EXTRABYTES[c];
if extra=0 then exit else // invalid leading byte
for i := 1 to extra do begin
if byte(U^) and $c0<>$80 then
exit; // invalid input content
c := c shl 6+byte(U^);
inc(U);
end;
with UTF8_EXTRA[extra] do begin
dec(c,offset);
if c<minimum then
exit; // invalid input content
end;
result := c;
end;
function GetHighUTF8UCS4Inlined(var U: PUTF8Char): PtrUInt;
{$ifdef HASINLINE}inline;{$endif}
var extra,i: PtrInt;
c: PtrUInt;
begin
result := 0;
c := byte(U^); // here U^>=#80
inc(U);
extra := UTF8_EXTRABYTES[c];
if extra=0 then exit else // invalid leading byte
for i := 1 to extra do begin
if byte(U^) and $c0<>$80 then
exit; // invalid input content
c := c shl 6+byte(U^);
inc(U);
end;
with UTF8_EXTRA[extra] do begin
dec(c,offset);
if c<minimum then
exit; // invalid input content
end;
result := c;
end;
function GetNextUTF8Upper(var U: PUTF8Char): PtrUInt;
begin
result := ord(U^);
if result=0 then
exit;
if result<=127 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;
function FindNextUTF8WordBegin(U: PUTF8Char): PUTF8Char;
var c: cardinal;
V: PUTF8Char;
begin
result := nil;
repeat
c := GetNextUTF8Upper(U);
if c=0 then
exit;
until (c>=127) or not(tcWord in TEXT_BYTES[c]);
repeat
V := U;
c := GetNextUTF8Upper(U);
if c=0 then
exit;
until (c<127) and (tcWord in TEXT_BYTES[c]);
result := V;
end;
{$ifdef USENORMTOUPPER}
function AnsiICompW(u1, u2: PWideChar): PtrInt; {$ifdef HASINLINE}inline;{$endif}
var C1,C2: PtrInt;
table: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperAnsi7Byte{$else}PNormTableByte{$endif};
begin
if u1<>u2 then
if u1<>nil then
if u2<>nil then begin
{$ifndef CPUX86NOTPIC}table := @NormToUpperAnsi7Byte;{$endif}
repeat
C1 := PtrInt(u1^);
C2 := PtrInt(u2^);
result := C1-C2;
if result<>0 then begin
if (C1>255) or (C2>255) then exit;
result := table[C1]-table[C2];
if result<>0 then exit;
end;
if (C1=0) or (C2=0) then break;
inc(u1);
inc(u2);
until false;
end else
result := 1 else // u2=''
result := -1 else // u1=''
result := 0; // u1=u2
end;
{$ifdef PUREPASCAL}
function AnsiIComp(Str1, Str2: pointer): PtrInt;
var C1,C2: byte; // integer/PtrInt are actually slower on FPC
lookupper: PByteArray; // better x86-64 / PIC asm generation
begin
result := PtrInt(PtrUInt(Str2))-PtrInt(PtrUInt(Str1));
if result<>0 then
if Str1<>nil then
if Str2<>nil then begin
lookupper := @NormToUpperByte;
repeat
C1 := lookupper[PByteArray(Str1)[0]];
C2 := lookupper[PByteArray(Str1)[result]];
inc(PByte(Str1));
until (C1=0) or (C1<>C2);
result := C1-C2;
end else
result := 1 else // Str2=''
result := -1; // Str1=''
end;
{$else}
function AnsiIComp(Str1, Str2: pointer): PtrInt; {$ifdef FPC} nostackframe; assembler; {$endif}
asm // fast 8 bits WinAnsi comparison using the NormToUpper[] array
cmp eax, edx
je @2
test eax, edx // is either of the strings perhaps nil?
jz @3
@0: push ebx // compare the first character (faster quicksort)
movzx ebx, byte ptr[eax] // ebx=S1[1]
movzx ecx, byte ptr[edx] // ecx=S2[1]
test ebx, ebx
jz @z
cmp ebx, ecx
je @s
mov bl, byte ptr[NormToUpper + ebx]
mov cl, byte ptr[NormToUpper + ecx]
cmp ebx, ecx
je @s
mov eax, ebx
pop ebx
sub eax, ecx // return S1[1]-S2[1]
ret
@2b: pop ebx
@2: xor eax, eax
ret
@3: test eax, eax // S1=''
jz @4
test edx, edx // S2='' ?
jnz @0
mov eax, 1 // return 1 (S1>S2)
ret
@s: inc eax
inc edx
mov bl, [eax] // ebx=S1[i]
mov cl, [edx] // ecx=S2[i]
test ebx, ebx
je @z // end of S1
cmp ebx, ecx
je @s
mov bl, byte ptr[NormToUpper + ebx]
mov cl, byte ptr[NormToUpper + ecx]
cmp ebx, ecx
je @s
mov eax, ebx
pop ebx
sub eax, ecx // return S1[i]-S2[i]
ret
@z: cmp ebx, ecx // S1=S2?
jz @2b
pop ebx
@4: mov eax, -1 // return -1 (S1<S2)
end;
{$endif PUREPASCAL}
function ConvertCaseUTF8(P: PUTF8Char; const Table: TNormTableByte): PtrInt;
var D,S: PUTF8Char;
c: PtrUInt;
extra,i: PtrInt;
begin
result := 0;
if P=nil then
exit;
D := P;
repeat
c := byte(P[0]);
inc(P);
if c=0 then
break;
if c<=127 then begin
D[result] := AnsiChar(Table[c]);
inc(result);
end else begin
extra := UTF8_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);
MoveSmall(S,D+result,extra);
inc(result,extra);
end;
until false;
end;
function UpperCaseU(const S: RawUTF8): RawUTF8;
var LS,LD: integer;
begin
LS := length(S);
FastSetString(result,pointer(S),LS);
LD := ConvertCaseUTF8(pointer(result),NormToUpperByte);
if LS<>LD then
SetLength(result,LD);
end;
function LowerCaseU(const S: RawUTF8): RawUTF8;
var LS,LD: integer;
begin
LS := length(S);
FastSetString(result,pointer(S),LS);
LD := ConvertCaseUTF8(pointer(result),NormToLowerByte);
if LS<>LD then
SetLength(result,LD);
end;
function UTF8IComp(u1, u2: PUTF8Char): PtrInt;
var c2: PtrInt;
table: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperByte{$else}PNormTableByte{$endif};
begin // fast UTF-8 comparison using the NormToUpper[] array for all 8 bits values
{$ifndef CPUX86NOTPIC}table := @NormToUpperByte;{$endif}
if u1<>u2 then
if u1<>nil then
if u2<>nil then
repeat
result := ord(u1^);
c2 := ord(u2^);
if result<=127 then
if result<>0 then begin
inc(u1);
result := table[result];
if c2<=127 then begin
if c2=0 then exit; // u1>u2 -> return u1^
inc(u2);
dec(result,table[c2]);
if result<>0 then exit;
continue;
end;
end else begin // u1^=#0 -> end of u1 reached
if c2<>0 then // end of u2 reached -> u1=u2 -> return 0
result := -1; // u1<u2
exit;
end else begin
result := GetHighUTF8UCS4Inlined(u1);
if result and $ffffff00=0 then
result := table[result]; // 8 bits to upper, 32-bit as is
end;
if c2<=127 then begin
if c2=0 then exit; // u1>u2 -> return u1^
inc(u2);
dec(result,table[c2]);
if result<>0 then exit;
continue;
end else begin
c2 := GetHighUTF8UCS4Inlined(u2);
if c2<=255 then
dec(result,table[c2]) else // 8 bits to upper
dec(result,c2); // 32-bit widechar returns diff
if result<>0 then exit;
end;
until false else
result := 1 else // u2=''
result := -1 else // u1=''
result := 0; // u1=u2
end;
function UTF8ILComp(u1, u2: PUTF8Char; L1,L2: cardinal): PtrInt;
var c2: PtrInt;
extra,i: integer;
table: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperByte{$else}PNormTableByte{$endif};
label neg,pos;
begin // fast UTF-8 comparison using the NormToUpper[] array for all 8 bits values
{$ifndef CPUX86NOTPIC}table := @NormToUpperByte;{$endif}
if u1<>u2 then
if (u1<>nil) and (L1<>0) then
if (u2<>nil) and (L2<>0) then
repeat
result := ord(u1^);
c2 := ord(u2^);
inc(u1);
dec(L1);
if result<=127 then begin
result := table[result];
if c2<=127 then begin
dec(result,table[c2]);
dec(L2);
inc(u2);
if result<>0 then
exit else
if L1<>0 then
if L2<>0 then
continue else // L1>0 and L2>0 -> next char
goto pos else // L1>0 and L2=0 -> u1>u2
if L2<>0 then
goto neg else // L1=0 and L2>0 -> u1<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 := table[result]; // 8 bits to upper, 32-bit as is
end;
// here result=NormToUpper[u1^]
inc(u2);
dec(L2);
if c2<=127 then begin
dec(result,table[c2]);
if result<>0 then exit;
end else begin
extra := UTF8_EXTRABYTES[c2];
if extra=0 then goto pos;
dec(L2,extra);
if integer(L2)<0 then goto pos;
for i := 0 to extra-1 do
c2 := c2 shl 6+PByteArray(u2)[i];
dec(c2,UTF8_EXTRA[extra].offset);
inc(u2,extra);
if c2 and $ffffff00=0 then
dec(result,table[c2]) else // 8 bits to upper
dec(result,c2); // returns 32-bit diff
if result<>0 then exit;
end;
// here we have result=NormToUpper[u2^]-NormToUpper[u1^]=0
if L1=0 then // test if we reached end of u1 or end of u2
if L2=0 then exit // u1=u2
else goto neg else // 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, especially since inlined
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 tcWord in TEXT_CHARS[NormToUpper[A^]] then break else inc(A); {$else}
if tcWord in TEXT_CHARS[A^] then break else inc(A);
{$endif}
until false;
// 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 (tcWord in TEXT_CHARS[NormToUpper[A^]]) then break else inc(A);
{$else} if not (tcWord in TEXT_CHARS[A^]) then break else inc(A); {$endif}
until false;
until false;
end;
function FindUnicode(PW, Upper: PWideChar; UpperLen: PtrInt): boolean;
var Start: PWideChar;
w: PtrUInt;
begin
result := false;
if (PW=nil) or (Upper=nil) then exit;
repeat
// go to beginning of next word
repeat
w := ord(PW^);
if w=0 then exit else
if (w>126) or (tcWord in TEXT_BYTES[w]) then
Break;
inc(PW);
until false;
Start := PW;
// search end of word matching UpperLen characters
repeat
inc(PW);
w := ord(PW^);
until (PW-Start>=UpperLen) or
(w=0) or ((w<126) and (not(tcWord in TEXT_BYTES[w])));
if PW-Start>=UpperLen then
if CompareStringW(LOCALE_USER_DEFAULT,NORM_IGNORECASE,Start,UpperLen,Upper,UpperLen)=2 then begin
result := true; // match found
exit;
end;
// not found: go to end of current word
repeat
w := ord(PW^);
if w=0 then exit else
if ((w<126) and (not(tcWord in TEXT_BYTES[w]))) then Break;
inc(PW);
until false;
until false;
end;
function FindUTF8(U: PUTF8Char; UpperValue: PAnsiChar): boolean;
var ValueStart: PAnsiChar;
{$ifdef USENORMTOUPPER}
c: PtrUInt;
FirstChar: AnsiChar;
label Next;
{$else}
ch: AnsiChar;
{$endif}
begin
result := false;
if (U=nil) or (UpperValue=nil) then exit;
{$ifdef USENORMTOUPPER}
// handles 8-bits WinAnsi chars inside UTF-8 encoded data
FirstChar := UpperValue^;
ValueStart := UpperValue+1;
repeat
// test beginning of word
repeat
c := byte(U^);
inc(U);
if c=0 then exit else
if c<=127 then begin
if tcWord in TEXT_BYTES[c] then
if PAnsiChar(@NormToUpper)[c]<>FirstChar then
goto Next else
break;
end else
if c and $20=0 then begin // fast direct process $0..$7ff
c := c shl 6+byte(U^)-$3080;
inc(U);
if c<=255 then begin
c := NormToUpperByte[c];
if tcWord in TEXT_BYTES[c] then
if AnsiChar(c)<>FirstChar then
goto Next else
break;
end;
end else
if UTF8_EXTRABYTES[c]=0 then
exit else // invalid leading byte
inc(U,UTF8_EXTRABYTES[c]); // just ignore surrogates for soundex
until false;
// here we had the first char match -> check if this word match UpperValue
UpperValue := ValueStart;
repeat
if UpperValue^=#0 then begin
result := true; // UpperValue found!
exit;
end;
c := byte(U^); inc(U); // next chars
if c=0 then exit else
if c<=127 then begin
if PAnsiChar(@NormToUpper)[c]<>UpperValue^ then break;
end else
if c and $20=0 then begin
c := c shl 6+byte(U^)-$3080;
inc(U);
if (c>255) or (PAnsiChar(@NormToUpper)[c]<>UpperValue^) then break;
end else begin
if UTF8_EXTRABYTES[c]=0 then
exit else // invalid leading byte
inc(U,UTF8_EXTRABYTES[c]);
break;
end;
inc(UpperValue);
until false;
Next: // find beginning of next word
U := FindNextUTF8WordBegin(U);
until U=nil;
{$else}
// this tiny version only handles 7-bits ansi chars and ignore all UTF-8 chars
ValueStart := UpperValue;
repeat
// find beginning of word
repeat
if byte(U^)=0 then exit else
if byte(U^)<=127 then
if byte(U^) in IsWord then
break else
inc(U) else
if byte(U^) and $20=0 then
inc(U,2) else
inc(U,3);
until false;
// check if this word is the UpperValue
UpperValue := ValueStart;
repeat
ch := NormToUpperAnsi7[U^];
if ch<>UpperValue^ then break;
inc(UpperValue);
if UpperValue^=#0 then begin
result := true; // UpperValue found!
exit;
end;
inc(U);
if byte(U^)=0 then exit else
if byte(U^) and $80<>0 then break; // 7 bits char check only
until false;
// find beginning of next word
U := FindNextUTF8WordBegin(U);
until U=nil;
{$endif}
end;
function HexDisplayToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: integer): boolean;
var b,c: byte;
tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif};
begin
result := false; // return false if any invalid char
if (Hex=nil) or (Bin=nil) then
exit;
{$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64
if BinBytes>0 then begin
inc(Bin,BinBytes-1);
repeat
b := tab[Ord(Hex[0])];
c := tab[Ord(Hex[1])];
if (b>15) or (c>15) then
exit;
b := b shl 4; // better FPC generation code in small explicit steps
b := b or c;
Bin^ := b;
dec(Bin);
inc(Hex,2);
dec(BinBytes);
until BinBytes=0;
end;
result := true; // correct content in Hex
end;
function HexDisplayToCardinal(Hex: PAnsiChar; out aValue: cardinal): boolean;
begin
result := HexDisplayToBin(Hex,@aValue,SizeOf(aValue));
if not result then
aValue := 0;
end;
function HexDisplayToInt64(Hex: PAnsiChar; out aValue: Int64): boolean;
begin
result := HexDisplayToBin(Hex,@aValue,SizeOf(aValue));
if not result then
aValue := 0;
end;
function HexDisplayToInt64(const Hex: RawByteString): Int64;
begin
if not HexDisplayToBin(pointer(Hex),@result,SizeOf(result)) then
result := 0;
end;
function HexToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: Integer): boolean;
var b,c: byte;
tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif};
begin
result := false; // return false if any invalid char
if Hex=nil then
exit;
{$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64
if BinBytes>0 then
if Bin<>nil then
repeat
b := tab[Ord(Hex[0])];
c := tab[Ord(Hex[1])];
if (b>15) or (c>15) then
exit;
inc(Hex,2);
b := b shl 4;
b := b or c;
Bin^ := b;
inc(Bin);
dec(BinBytes);
until BinBytes=0 else
repeat // Bin=nil -> validate Hex^ input
if (tab[Ord(Hex[0])]>15) or (tab[Ord(Hex[1])]>15) then
exit;
inc(Hex,2);
dec(BinBytes);
until BinBytes=0;
result := true; // conversion OK
end;
procedure HexToBinFast(Hex: PAnsiChar; Bin: PByte; BinBytes: Integer);
var tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif};
c: byte;
begin
{$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64
if BinBytes>0 then
repeat
c := tab[ord(Hex[0])];
c := c shl 4;
c := tab[ord(Hex[1])] or c;
Bin^ := c;
inc(Hex,2);
inc(Bin);
dec(BinBytes);
until BinBytes=0;
end;
function OctToBin(Oct: PAnsiChar; Bin: PByte): PtrInt;
var c, v: byte;
label _nxt;
begin
result := PtrInt(Bin);
if Oct <> nil then
repeat
c := ord(Oct^);
inc(Oct);
if c <> ord('\') then begin
if c = 0 then
break;
_nxt: Bin^ := c;
inc(Bin);
continue;
end;
c := ord(Oct^);
inc(Oct);
if c = ord('\') then
goto _nxt;
dec(c, ord('0'));
if c > 3 then
break; // stop at malformated input (includes #0)
c := c shl 6;
v := c;
c := ord(Oct[0]);
dec(c, ord('0'));
if c > 7 then
break;
c := c shl 3;
v := v or c;
c := ord(Oct[1]);
dec(c, ord('0'));
if c > 7 then
break;
c := c or v;
Bin^ := c;
inc(Bin);
inc(Oct, 2);
until false;
result := PtrInt(Bin)-result;
end;
function OctToBin(const Oct: RawUTF8): RawByteString;
var tmp: TSynTempBuffer;
L: integer;
begin
tmp.Init(length(Oct));
try
L := OctToBin(pointer(Oct), tmp.buf);
SetString(result, PAnsiChar(tmp.buf), L);
finally
tmp.Done;
end;
end;
function IsHex(const Hex: RawByteString; BinBytes: integer): boolean;
begin
result := (length(Hex)=BinBytes*2) and SynCommons.HexToBin(pointer(Hex),nil,BinBytes);
end;
function HexToCharValid(Hex: PAnsiChar): boolean;
begin
result := (ConvertHexToBin[Ord(Hex[0])]<=15) and
(ConvertHexToBin[Ord(Hex[1])]<=15);
end;
function HexToChar(Hex: PAnsiChar; Bin: PUTF8Char): boolean;
var B,C: PtrUInt;
tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif};
begin
if Hex<>nil then begin
{$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64
B := tab[Ord(Hex[0])];
C := tab[Ord(Hex[1])];
if (B<=15) and (C<=15) then begin
if Bin<>nil then
Bin^ := AnsiChar(B shl 4+C);
result := true;
exit;
end;
end;
result := false; // return false if any invalid char
end;
function HexToWideChar(Hex: PAnsiChar): cardinal;
var B: PtrUInt;
begin
result := ConvertHexToBin[Ord(Hex[0])];
if result<=15 then begin
B := ConvertHexToBin[Ord(Hex[1])];
if B<=15 then begin
result := result shl 4+B;
B := ConvertHexToBin[Ord(Hex[2])];
if B<=15 then begin
result := result shl 4+B;
B := ConvertHexToBin[Ord(Hex[3])];
if B<=15 then begin
result := result shl 4+B;
exit;
end;
end;
end;
end;
result := 0;
end;
{ --------- Base64 encoding/decoding }
type
TBase64Enc = array[0..63] of AnsiChar;
PBase64Enc = ^TBase64Enc;
TBase64Dec = array[AnsiChar] of shortint;
PBase64Dec = ^TBase64Dec;
const
b64enc: TBase64Enc =
'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
b64URIenc: TBase64Enc =
'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_';
var
/// a conversion table from Base64 text into binary data
// - used by Base64ToBin/IsBase64 functions
// - contains -1 for invalid char, -2 for '=', 0..63 for b64enc[] chars
ConvertBase64ToBin, ConvertBase64URIToBin: TBase64Dec;
function Base64AnyDecode(const decode: TBase64Dec; sp,rp: PAnsiChar; len: PtrInt): boolean;
var c, ch: PtrInt;
begin
result := false;
while len>=4 do begin
c := decode[sp[0]];
if c<0 then
exit;
c := c shl 6;
ch := decode[sp[1]];
if ch<0 then
exit;
c := (c or ch) shl 6;
ch := decode[sp[2]];
if ch<0 then
exit;
c := (c or ch) shl 6;
ch := decode[sp[3]];
if ch<0 then
exit;
c := c or ch;
rp[2] := AnsiChar(c);
c := c shr 8;
rp[1] := AnsiChar(c);
c := c shr 8;
rp[0] := AnsiChar(c);
dec(len,4);
inc(rp,3);
inc(sp,4);
end;
if len>=2 then begin
c := decode[sp[0]];
if c<0 then
exit;
c := c shl 6;
ch := decode[sp[1]];
if ch<0 then
exit;
if len=2 then
rp[0] := AnsiChar((c or ch) shr 4) else begin
c := (c or ch) shl 6;
ch := decode[sp[2]];
if ch<0 then
exit;
c := (c or ch) shr 2;
rp[1] := AnsiChar(c);
rp[0] := AnsiChar(c shr 8);
end;
end;
result := true;
end;
function Base64Decode(sp,rp: PAnsiChar; len: PtrInt): boolean; {$ifdef FPC}inline;{$endif}
var tab: PBase64Dec; // use local register
begin
tab := @ConvertBase64ToBin;
len := len shl 2; // len was the number of 4 chars chunks in sp
if (len>0) and (tab[sp[len-2]]>=0) then
if tab[sp[len-1]]>=0 then else
dec(len) else
dec(len,2); // Base64AnyDecode() algorithm ignores the trailing '='
result := Base64AnyDecode(tab^,sp,rp,len);
end;
{$ifdef PUREPASCAL}
function Base64EncodeMain(rp, sp: PAnsiChar; len: cardinal): integer;
var c: cardinal;
enc: PBase64Enc; // use local register
begin
enc := @b64enc;
len := len div 3;
result := len;
if len<>0 then
repeat
c := (ord(sp[0]) shl 16) or (ord(sp[1]) shl 8) or ord(sp[2]);
rp[0] := enc[(c shr 18) and $3f];
rp[1] := enc[(c shr 12) and $3f];
rp[2] := enc[(c shr 6) and $3f];
rp[3] := enc[c and $3f];
inc(rp,4);
inc(sp,3);
dec(len);
until len=0;
end;
{$else PUREPASCAL}
function Base64EncodeMain(rp, sp: PAnsiChar; len: cardinal): integer;
{$ifdef FPC} nostackframe; assembler; {$endif}
asm // eax=rp edx=sp ecx=len - pipeline optimized version by AB
push ebx
push esi
push edi
push ebp
mov ebx, edx
mov esi, eax
mov eax, ecx
mov edx, 1431655766 // faster eax=len div 3 using reciprocal
sar ecx, 31
imul edx
mov eax, edx
sub eax, ecx
mov edi, offset b64enc
mov ebp, eax
push eax
jz @z
// edi=b64enc[] ebx=sp esi=rp ebp=len div 3
xor eax, eax
@1: // read 3 bytes from sp
movzx edx, byte ptr[ebx]
shl edx, 16
mov al, [ebx + 2]
mov ah, [ebx + 1]
add ebx, 3
or eax, edx
// encode as Base64
mov ecx, eax
mov edx, eax
shr ecx, 6
and edx, $3f
and ecx, $3f
mov dh, [edi + edx]
mov dl, [edi + ecx]
mov ecx, eax
shr eax, 12
shr ecx, 18
shl edx, 16
and ecx, $3f
and eax, $3f
mov cl, [edi + ecx]
mov ch, [edi + eax]
or ecx, edx
// write the 4 encoded bytes into rp
mov [esi], ecx
add esi, 4
dec ebp
jnz @1
@z: pop eax // result := len div 3
pop ebp
pop edi
pop esi
pop ebx
end;
{$endif PUREPASCAL}
procedure Base64EncodeTrailing(rp, sp: PAnsiChar; len: cardinal);
{$ifdef HASINLINE}inline;{$endif}
var c: cardinal;
enc: PBase64Enc; // use local register
begin
enc := @b64enc;
case len of
1: begin
c := ord(sp[0]) shl 4;
rp[0] := enc[(c shr 6) and $3f];
rp[1] := enc[c and $3f];
PWord(rp+2)^ := ord('=')+ord('=') shl 8;
end;
2: begin
c := (ord(sp[0]) shl 10) or (ord(sp[1]) shl 2);
rp[0] := enc[(c shr 12) and $3f];
rp[1] := enc[(c shr 6) and $3f];
rp[2] := enc[c and $3f];
rp[3] := '=';
end;
end;
end;
procedure Base64Encode(rp, sp: PAnsiChar; len: cardinal);
var main: cardinal;
begin
main := Base64EncodeMain(rp,sp,len);
Base64EncodeTrailing(rp+main*4,sp+main*3,len-main*3);
end;
function BinToBase64Length(len: PtrUInt): PtrUInt;
begin
result := ((len+2)div 3)*4;
end;
function BinToBase64(const s: RawByteString): RawUTF8;
var len: integer;
begin
result := '';
len := length(s);
if len=0 then
exit;
FastSetString(result,nil,BinToBase64Length(len));
Base64Encode(pointer(result),pointer(s),len);
end;
function BinToBase64Short(Bin: PAnsiChar; BinBytes: integer): shortstring;
var destlen: integer;
begin
result := '';
if BinBytes=0 then
exit;
destlen := BinToBase64Length(BinBytes);
if destlen>255 then
exit; // avoid buffer overflow
result[0] := AnsiChar(destlen);
Base64Encode(@result[1],Bin,BinBytes);
end;
function BinToBase64Short(const s: RawByteString): shortstring;
begin
result := BinToBase64Short(pointer(s),length(s));
end;
function BinToBase64(Bin: PAnsiChar; BinBytes: integer): RawUTF8;
begin
result := '';
if BinBytes=0 then
exit;
FastSetString(result,nil,BinToBase64Length(BinBytes));
Base64Encode(pointer(result),Bin,BinBytes);
end;
function BinToBase64(const data, Prefix, Suffix: RawByteString; WithMagic: boolean): RawUTF8;
var lendata,lenprefix,lensuffix,len: integer;
res: PByteArray absolute result;
begin
result := '';
lendata := length(data);
lenprefix := length(Prefix);
lensuffix := length(Suffix);
if lendata+lenprefix+lensuffix=0 then
exit;
len := ((lendata+2) div 3)*4+lenprefix+lensuffix;
if WithMagic then
inc(len,3);
FastSetString(result,nil,len);
if lenprefix>0 then
MoveSmall(pointer(Prefix),res,lenprefix);
if WithMagic then begin
PInteger(@res[lenprefix])^ := JSON_BASE64_MAGIC;
inc(lenprefix,3);
end;
Base64Encode(@res[lenprefix],pointer(data),lendata);
if lensuffix>0 then
MoveSmall(pointer(Suffix),@res[len-lensuffix],lensuffix);
end;
function BinToBase64WithMagic(const data: RawByteString): RawUTF8;
var len: integer;
begin
result := '';
len := length(data);
if len=0 then
exit;
FastSetString(result,nil,((len+2) div 3)*4+3);
PInteger(pointer(result))^ := JSON_BASE64_MAGIC;
Base64Encode(PAnsiChar(pointer(result))+3,pointer(data),len);
end;
function BinToBase64WithMagic(Data: pointer; DataLen: integer): RawUTF8;
begin
result := '';
if DataLen<=0 then
exit;
FastSetString(result,nil,((DataLen+2) div 3)*4+3);
PInteger(pointer(result))^ := JSON_BASE64_MAGIC;
Base64Encode(PAnsiChar(pointer(result))+3,Data,DataLen);
end;
function IsBase64Internal(sp: PAnsiChar; len: PtrInt; dec: PBase64Dec): boolean;
var i: PtrInt;
begin
result := false;
if (len=0) or (len and 3<>0) then
exit;
for i := 0 to len-5 do
if dec[sp[i]]<0 then
exit;
inc(sp,len-4);
if (dec[sp[0]]=-1) or (dec[sp[1]]=-1) or
(dec[sp[2]]=-1) or (dec[sp[3]]=-1) then
exit;
result := true; // layout seems correct
end;
function IsBase64(sp: PAnsiChar; len: PtrInt): boolean;
begin
result := IsBase64Internal(sp,len,@ConvertBase64ToBin);
end;
function IsBase64(const s: RawByteString): boolean;
begin
result := IsBase64Internal(pointer(s),length(s),@ConvertBase64ToBin);
end;
function Base64ToBinLengthSafe(sp: PAnsiChar; len: PtrInt): PtrInt;
var dec: PBase64Dec;
begin
dec := @ConvertBase64ToBin;
if IsBase64Internal(sp,len,dec) then begin
if dec[sp[len-2]]>=0 then
if dec[sp[len-1]]>=0 then
result := 0 else
result := 1 else
result := 2;
result := (len shr 2)*3-result;
end else
result := 0;
end;
function Base64ToBinLength(sp: PAnsiChar; len: PtrInt): PtrInt;
var dec: PBase64Dec;
begin
result := 0;
if (len=0) or (len and 3<>0) then
exit;
dec := @ConvertBase64ToBin;
if dec[sp[len-2]]>=0 then
if dec[sp[len-1]]>=0 then
result := 0 else
result := 1 else
result := 2;
result := (len shr 2)*3-result;
end;
function Base64ToBin(const s: RawByteString): RawByteString;
begin
Base64ToBinSafe(pointer(s),length(s),result);
end;
function Base64ToBin(sp: PAnsiChar; len: PtrInt): RawByteString;
begin
Base64ToBinSafe(sp,len,result);
end;
function Base64ToBin(sp: PAnsiChar; len: PtrInt; var data: RawByteString): boolean;
begin
result := Base64ToBinSafe(sp,len,data);
end;
function Base64ToBinSafe(const s: RawByteString): RawByteString;
begin
Base64ToBinSafe(pointer(s),length(s),result);
end;
function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt): RawByteString;
begin
Base64ToBinSafe(sp,len,result);
end;
function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt; var data: RawByteString): boolean;
var resultLen: PtrInt;
begin
resultLen := Base64ToBinLength(sp,len);
if resultLen<>0 then begin
SetString(data,nil,resultLen);
if ConvertBase64ToBin[sp[len-2]]>=0 then
if ConvertBase64ToBin[sp[len-1]]>=0 then else
dec(len) else
dec(len,2); // adjust for Base64AnyDecode() algorithm
result := Base64AnyDecode(ConvertBase64ToBin,sp,pointer(data),len);
if not result then
data := '';
end else begin
result := false;
data := '';
end;
end;
function Base64ToBin(sp: PAnsiChar; len: PtrInt; var blob: TSynTempBuffer): boolean;
begin
blob.Init(Base64ToBinLength(sp,len));
result := (blob.len>0) and Base64Decode(sp,blob.buf,len shr 2);
end;
function Base64ToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt;
nofullcheck: boolean): boolean;
begin // nofullcheck is just ignored and deprecated
result := (bin<>nil) and (Base64ToBinLength(base64,base64len)=binlen) and
Base64Decode(base64,bin,base64len shr 2);
end;
function Base64ToBin(const base64: RawByteString; bin: PAnsiChar; binlen: PtrInt;
nofullcheck: boolean): boolean;
begin
result := Base64ToBin(pointer(base64),bin,length(base64),binlen,nofullcheck);
end;
{ --------- Base64 URI encoding/decoding }
{$ifdef PUREPASCAL}
procedure Base64uriEncode(rp, sp: PAnsiChar; len: cardinal);
var main, c: cardinal;
enc: PBase64Enc; // faster especially on x86_64 and PIC
begin
enc := @b64URIenc;
main := len div 3;
if main<>0 then begin
dec(len,main*3); // fast modulo
repeat
c := (ord(sp[0]) shl 16) or (ord(sp[1]) shl 8) or ord(sp[2]);
rp[0] := enc[(c shr 18) and $3f];
rp[1] := enc[(c shr 12) and $3f];
rp[2] := enc[(c shr 6) and $3f];
rp[3] := enc[c and $3f];
inc(rp,4);
inc(sp,3);
dec(main)
until main=0;
end;
case len of
1: begin
c := ord(sp[0]) shl 4;
rp[0] := enc[(c shr 6) and $3f];
rp[1] := enc[c and $3f];
end;
2: begin
c := (ord(sp[0]) shl 10) or (ord(sp[1]) shl 2);
rp[0] := enc[(c shr 12) and $3f];
rp[1] := enc[(c shr 6) and $3f];
rp[2] := enc[c and $3f];
end;
end;
end;
{$else PUREPASCAL}
function Base64uriEncodeMain(rp, sp: PAnsiChar; len: cardinal): integer;
{$ifdef FPC} nostackframe; assembler; {$endif}
asm // eax=rp edx=sp ecx=len - pipeline optimized version by AB
push ebx
push esi
push edi
push ebp
mov ebx, edx
mov esi, eax
mov eax, ecx
mov edx, 1431655766 // faster eax=len div 3 using reciprocal
sar ecx, 31
imul edx
mov eax, edx
sub eax, ecx
mov edi, offset b64urienc
mov ebp, eax
push eax
jz @z
// edi=b64urienc[] ebx=sp esi=rp ebp=len div 3
xor eax, eax
@1: // read 3 bytes from sp
movzx edx, byte ptr[ebx]
shl edx, 16
mov al, [ebx + 2]
mov ah, [ebx + 1]
add ebx, 3
or eax, edx
// encode as Base64uri
mov ecx, eax
mov edx, eax
shr ecx, 6
and edx, $3f
and ecx, $3f
mov dh, [edi + edx]
mov dl, [edi + ecx]
mov ecx, eax
shr eax, 12
shr ecx, 18
shl edx, 16
and ecx, $3f
and eax, $3f
mov cl, [edi + ecx]
mov ch, [edi + eax]
or ecx, edx
// write the 4 encoded bytes into rp
mov [esi], ecx
add esi, 4
dec ebp
jnz @1
@z: pop eax // result := len div 3
pop ebp
pop edi
pop esi
pop ebx
end;
procedure Base64uriEncodeTrailing(rp, sp: PAnsiChar; len: cardinal);
{$ifdef HASINLINE}inline;{$endif}
var c: cardinal;
begin
case len of
1: begin
c := ord(sp[0]) shl 4;
rp[0] := b64urienc[(c shr 6) and $3f];
rp[1] := b64urienc[c and $3f];
end;
2: begin
c := ord(sp[0]) shl 10 + ord(sp[1]) shl 2;
rp[0] := b64urienc[(c shr 12) and $3f];
rp[1] := b64urienc[(c shr 6) and $3f];
rp[2] := b64urienc[c and $3f];
end;
end;
end;
procedure Base64uriEncode(rp, sp: PAnsiChar; len: cardinal);
var main: cardinal;
begin
main := Base64uriEncodeMain(rp,sp,len);
Base64uriEncodeTrailing(rp+main*4,sp+main*3,len-main*3);
end;
{$endif PUREPASCAL}
function BinToBase64uriLength(len: PtrUInt): PtrUInt;
begin
result := (len div 3)*4;
case len-(result shr 2)*3 of // fast len mod 3
1: inc(result,2);
2: inc(result,3);
end;
end;
function BinToBase64uri(const s: RawByteString): RawUTF8;
var len: integer;
begin
result := '';
len := length(s);
if len=0 then
exit;
FastSetString(result,nil,BinToBase64uriLength(len));
Base64uriEncode(pointer(result),pointer(s),len);
end;
function BinToBase64uri(Bin: PAnsiChar; BinBytes: integer): RawUTF8;
begin
result := '';
if BinBytes<=0 then
exit;
FastSetString(result,nil,BinToBase64uriLength(BinBytes));
Base64uriEncode(pointer(result),Bin,BinBytes);
end;
function BinToBase64uriShort(Bin: PAnsiChar; BinBytes: integer): shortstring;
var len: integer;
begin
result := '';
if BinBytes<=0 then
exit;
len := BinToBase64uriLength(BinBytes);
if len>255 then
exit;
byte(result[0]) := len;
Base64uriEncode(@result[1],Bin,BinBytes);
end;
function Base64uriToBinLength(len: PtrInt): PtrInt;
begin
if len=0 then
result := 0 else begin
result := (len shr 2)*3;
case len and 3 of
1: result := 0;
2: inc(result,1);
3: inc(result,2);
end;
end;
end;
function Base64uriDecode(sp,rp: PAnsiChar; len: PtrInt): boolean;
begin
result := Base64AnyDecode(ConvertBase64URIToBin,sp,rp,len);
end;
function Base64uriToBin(sp: PAnsiChar; len: PtrInt): RawByteString;
begin
Base64uriToBin(sp,len,result);
end;
function Base64uriToBin(const s: RawByteString): RawByteString;
begin
Base64uriToBin(pointer(s),length(s),result);
end;
procedure Base64uriToBin(sp: PAnsiChar; len: PtrInt; var result: RawByteString);
var resultLen: PtrInt;
begin
resultLen := Base64uriToBinLength(len);
if resultLen<>0 then begin
SetString(result,nil,resultLen);
if Base64AnyDecode(ConvertBase64URIToBin,sp,pointer(result),len) then
exit;
end;
result := '';
end;
function Base64uriToBin(sp: PAnsiChar; len: PtrInt; var temp: TSynTempBuffer): boolean;
begin
temp.Init(Base64uriToBinLength(len));
result := (temp.len>0) and Base64AnyDecode(ConvertBase64URIToBin,sp,temp.buf,len);
end;
function Base64uriToBin(const base64: RawByteString; bin: PAnsiChar; binlen: PtrInt): boolean;
begin
result := Base64uriToBin(pointer(base64),bin,length(base64),binlen);
end;
function Base64uriToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt): boolean;
var resultLen: PtrInt;
begin
resultLen := Base64uriToBinLength(base64len);
result := (resultLen=binlen) and
Base64AnyDecode(ConvertBase64URIToBin,base64,bin,base64len);
end;
procedure Base64ToURI(var base64: RawUTF8);
var P: PUTF8Char;
begin
P := UniqueRawUTF8(base64);
if P<>nil then
repeat
case P^ of
#0: break;
'+': P^ := '-';
'/': P^ := '_';
'=': begin // trim unsignificant trailing '=' characters
SetLength(base64,P-pointer(base64));
break;
end;
end;
inc(P);
until false;
end;
function BinToSource(const ConstName, Comment: RawUTF8;
Data: pointer; Len, PerLine: integer; const Suffix: RawUTF8): RawUTF8;
var W: TTextWriter;
temp: TTextWriterStackBuffer;
begin
if (Data=nil) or (Len<=0) or (PerLine<=0) then
result := '' else begin
W := TTextWriter.CreateOwnedStream(temp,Len*5+50+length(Comment)+length(Suffix));
try
BinToSource(W,ConstName,Comment,Data,Len,PerLine);
if Suffix<>'' then begin
W.AddString(Suffix);
W.AddCR;
end;
W.SetText(result);
finally
W.Free;
end;
end;
end;
procedure BinToSource(Dest: TTextWriter; const ConstName, Comment: RawUTF8;
Data: pointer; Len, PerLine: integer);
var line,i: integer;
P: PByte;
begin
if (Dest=nil) or (Data=nil) or (Len<=0) or (PerLine<=0) then
exit;
Dest.AddShort('const');
if Comment<>'' then
Dest.Add(#13#10' // %',[Comment]);
Dest.Add(#13#10' %: array[0..%] of byte = (',[ConstName,Len-1]);
P := pointer(Data);
repeat
if len>PerLine then
line := PerLine else
line := Len;
Dest.AddShort(#13#10' ');
for i := 0 to line-1 do begin
Dest.Add('$');
Dest.AddByteToHex(P^);
inc(P);
Dest.Add(',');
end;
dec(Len,line);
until Len=0;
Dest.CancelLastComma;
Dest.Add(');'#13#10' %_LEN = SizeOf(%);'#13#10,[ConstName,ConstName]);
end;
{$ifdef KYLIX3}
function UpperCaseUnicode(const S: RawUTF8): RawUTF8;
begin
result := WideStringToUTF8(WideUpperCase(UTF8ToWideString(S)));
end;
function LowerCaseUnicode(const S: RawUTF8): RawUTF8;
begin
result := WideStringToUTF8(WideLowerCase(UTF8ToWideString(S)));
end;
{$else}
function UpperCaseUnicode(const S: RawUTF8): RawUTF8;
var tmp: TSynTempBuffer;
len: integer;
begin
if S='' then begin
result := '';
exit;
end;
tmp.Init(length(s)*2);
len := UTF8ToWideChar(tmp.buf,pointer(S),length(S)) shr 1;
RawUnicodeToUtf8(tmp.buf,CharUpperBuffW(tmp.buf,len),result);
tmp.Done;
end;
function LowerCaseUnicode(const S: RawUTF8): RawUTF8;
var tmp: TSynTempBuffer;
len: integer;
begin
if S='' then begin
result := '';
exit;
end;
tmp.Init(length(s)*2);
len := UTF8ToWideChar(tmp.buf,pointer(S),length(S)) shr 1;
RawUnicodeToUtf8(tmp.buf,CharLowerBuffW(tmp.buf,len),result);
tmp.Done;
end;
{$endif KYLIX3}
function IsCaseSensitive(const S: RawUTF8): boolean;
begin
result := IsCaseSensitive(pointer(S),length(S));
end;
function IsCaseSensitive(P: PUTF8Char; PLen: PtrInt): boolean;
begin
result := true;
if (P<>nil) and (PLen>0) then
repeat
if ord(P^) in [ord('a')..ord('z'), ord('A')..ord('Z')] then
exit;
inc(P);
dec(PLen);
until PLen=0;
result := false;
end;
function UpperCase(const S: RawUTF8): RawUTF8;
var L, i: PtrInt;
begin
L := length(S);
FastSetString(Result,pointer(S),L);
for i := 0 to L-1 do
if PByteArray(result)[i] in [ord('a')..ord('z')] then
dec(PByteArray(result)[i],32);
end;
procedure UpperCaseCopy(Text: PUTF8Char; Len: PtrInt; var result: RawUTF8);
var i: PtrInt;
begin
FastSetString(result,Text,Len);
for i := 0 to Len-1 do
if PByteArray(result)[i] in [ord('a')..ord('z')] then
dec(PByteArray(result)[i],32);
end;
procedure UpperCaseCopy(const Source: RawUTF8; var Dest: RawUTF8);
var L, i: PtrInt;
begin
L := length(Source);
FastSetString(Dest,pointer(Source),L);
for i := 0 to L-1 do
if PByteArray(Dest)[i] in [ord('a')..ord('z')] then
dec(PByteArray(Dest)[i],32);
end;
procedure UpperCaseSelf(var S: RawUTF8);
var i: PtrInt;
P: PByteArray;
begin
P := UniqueRawUTF8(S);
for i := 0 to length(S)-1 do
if P[i] in [ord('a')..ord('z')] then
dec(P[i],32);
end;
function LowerCase(const S: RawUTF8): RawUTF8;
var L, i: PtrInt;
begin
L := length(S);
FastSetString(result,pointer(S),L);
for i := 0 to L-1 do
if PByteArray(result)[i] in [ord('A')..ord('Z')] then
inc(PByteArray(result)[i],32);
end;
procedure LowerCaseCopy(Text: PUTF8Char; Len: PtrInt; var result: RawUTF8);
var i: PtrInt;
begin
FastSetString(result,Text,Len);
for i := 0 to Len-1 do
if PByteArray(result)[i] in [ord('A')..ord('Z')] then
inc(PByteArray(result)[i],32);
end;
procedure LowerCaseSelf(var S: RawUTF8);
var i: PtrInt;
P: PByteArray;
begin
P := UniqueRawUTF8(S);
for i := 0 to length(S)-1 do
if P[i] in [ord('A')..ord('Z')] then
inc(P[i],32);
end;
function TrimLeft(const S: RawUTF8): RawUTF8;
var i, l: PtrInt;
begin
l := Length(S);
i := 1;
while (i <= l) and (S[i] <= ' ') do
Inc(i);
Result := Copy(S, i, Maxint);
end;
function TrimRight(const S: RawUTF8): RawUTF8;
var i: PtrInt;
begin
i := Length(S);
while (i > 0) and (S[i] <= ' ') do
Dec(i);
FastSetString(result,pointer(S),i);
end;
procedure TrimCopy(const S: RawUTF8; start, count: PtrInt;
var result: RawUTF8);
var L: PtrInt;
begin
if count>0 then begin
if start<=0 then
start := 1;
L := Length(S);
while (start<=L) and (S[start]<=' ') do begin
inc(start); dec(count); end;
dec(start);
dec(L,start);
if count<L then
L := count;
while L>0 do
if S[start+L]<=' ' then
dec(L) else
break;
if L>0 then begin
FastSetString(result,@PByteArray(S)[start],L);
exit;
end;
end;
result := '';
end;
type
TAnsiCharToWord = array[AnsiChar] of word;
TByteToWord = array[byte] of word;
var
/// fast lookup table for converting hexadecimal numbers from 0 to 15
// into their ASCII equivalence
// - is local for better code generation
TwoDigitsHex: array[byte] of array[1..2] of AnsiChar;
TwoDigitsHexW: TAnsiCharToWord absolute TwoDigitsHex;
TwoDigitsHexWB: array[byte] of word absolute TwoDigitsHex;
/// lowercase hexadecimal lookup table
TwoDigitsHexLower: array[byte] of array[1..2] of AnsiChar;
TwoDigitsHexWLower: TAnsiCharToWord absolute TwoDigitsHexLower;
TwoDigitsHexWBLower: array[byte] of word absolute TwoDigitsHexLower;
procedure BinToHex(Bin, Hex: PAnsiChar; BinBytes: integer);
{$ifdef PUREPASCAL}var tab: ^TAnsiCharToWord;{$endif}
begin
{$ifdef PUREPASCAL}tab := @TwoDigitsHexW;{$endif}
if BinBytes>0 then
repeat
PWord(Hex)^ := {$ifndef PUREPASCAL}TwoDigitsHexW{$else}tab{$endif}[Bin^];
inc(Bin);
inc(Hex,2);
dec(BinBytes);
until BinBytes=0;
end;
function BinToHex(const Bin: RawByteString): RawUTF8;
var L: integer;
begin
L := length(Bin);
FastSetString(result,nil,L*2);
SynCommons.BinToHex(pointer(Bin),pointer(Result),L);
end;
function BinToHex(Bin: PAnsiChar; BinBytes: integer): RawUTF8;
begin
FastSetString(result,nil,BinBytes*2);
SynCommons.BinToHex(Bin,pointer(Result),BinBytes);
end;
function HexToBin(const Hex: RawUTF8): RawByteString;
var L: integer;
begin
result := '';
L := length(Hex);
if L and 1<>0 then
L := 0 else // hexadecimal should be in char pairs
L := L shr 1;
SetLength(result,L);
if not SynCommons.HexToBin(pointer(Hex),pointer(result),L) then
result := '';
end;
function ByteToHex(P: PAnsiChar; Value: byte): PAnsiChar;
begin
PWord(P)^ := TwoDigitsHexWB[Value];
result := P+2;
end;
function EscapeBuffer(s,d: PAnsiChar; len,max: integer): PAnsiChar;
var i: integer;
begin
if len>max then
len := max;
for i := 1 to len do begin
if s^ in [' '..#126] then begin
d^ := s^;
inc(d);
end else begin
d^ := '$';
inc(d);
PWord(d)^ := TwoDigitsHexWB[ord(s^)];
inc(d,2);
end;
inc(s);
end;
if len=max then begin
PCardinal(d)^ := ord('.')+ord('.')shl 8+ord('.')shl 16;
inc(d,3);
end else
d^ := #0;
result := d;
end;
function LogEscape(source: PAnsiChar; sourcelen: integer; var temp: TLogEscape;
enabled: boolean): PAnsiChar;
begin
if enabled then begin
temp[0] := ' ';
EscapeBuffer(source,@temp[1],sourcelen,LOGESCAPELEN);
end else
temp[0] := #0;
result := @temp;
end;
function LogEscapeFull(const source: RawByteString): RawUTF8;
begin
result := LogEscapeFull(pointer(source),length(source));
end;
function LogEscapeFull(source: PAnsiChar; sourcelen: integer): RawUTF8;
begin
FastSetString(result,nil,sourcelen*3); // worse case
if sourcelen=0 then
exit;
sourcelen := EscapeBuffer(source,pointer(result),sourcelen,length(result))-pointer(result);
SetLength(result,sourcelen);
end;
function EscapeToShort(source: PAnsiChar; sourcelen: integer): shortstring;
begin
result[0] := AnsiChar(EscapeBuffer(source,@result[1],sourcelen,80)-@result[1]);
end;
function EscapeToShort(const source: RawByteString): shortstring; overload;
begin
result[0] := AnsiChar(EscapeBuffer(pointer(source),@result[1],length(source),80)-@result[1]);
end;
procedure BinToHexDisplay(Bin, Hex: PAnsiChar; BinBytes: integer);
{$ifdef PUREPASCAL}var tab: ^TAnsiCharToWord;{$endif}
begin
{$ifdef PUREPASCAL}tab := @TwoDigitsHexW;{$endif}
inc(Hex,BinBytes*2);
if BinBytes>0 then
repeat
dec(Hex,2);
PWord(Hex)^ := {$ifndef PUREPASCAL}TwoDigitsHexW{$else}tab{$endif}[Bin^];
inc(Bin);
dec(BinBytes);
until BinBytes=0;
end;
function BinToHexDisplay(Bin: PAnsiChar; BinBytes: integer): RawUTF8;
begin
FastSetString(result,nil,BinBytes*2);
BinToHexDisplay(Bin,pointer(result),BinBytes);
end;
procedure BinToHexLower(Bin, Hex: PAnsiChar; BinBytes: integer);
{$ifdef PUREPASCAL}var tab: ^TAnsiCharToWord;{$endif}
begin
{$ifdef PUREPASCAL}tab := @TwoDigitsHexWLower;{$endif}
if BinBytes>0 then
repeat
PWord(Hex)^ := {$ifndef PUREPASCAL}TwoDigitsHexWLower{$else}tab{$endif}[Bin^];
inc(Bin);
inc(Hex,2);
dec(BinBytes);
until BinBytes=0;
end;
function BinToHexLower(const Bin: RawByteString): RawUTF8;
begin
BinToHexLower(pointer(Bin),length(Bin),result);
end;
procedure BinToHexLower(Bin: PAnsiChar; BinBytes: integer; var result: RawUTF8);
begin
FastSetString(result,nil,BinBytes*2);
BinToHexLower(Bin,pointer(result),BinBytes);
end;
function BinToHexLower(Bin: PAnsiChar; BinBytes: integer): RawUTF8;
begin
BinToHexLower(Bin,BinBytes,result);
end;
procedure BinToHexDisplayLower(Bin, Hex: PAnsiChar; BinBytes: PtrInt);
{$ifdef PUREPASCAL}var tab: ^TAnsiCharToWord;{$endif}
begin
if (Bin=nil) or (Hex=nil) or (BinBytes<=0) then
exit;
{$ifdef PUREPASCAL}tab := @TwoDigitsHexWLower;{$endif}
inc(Hex,BinBytes*2);
repeat
dec(Hex,2);
PWord(Hex)^ := {$ifdef PUREPASCAL}tab{$else}TwoDigitsHexWLower{$endif}[Bin^];
inc(Bin);
dec(BinBytes);
until BinBytes=0;
end;
function BinToHexDisplayLower(Bin: PAnsiChar; BinBytes: integer): RawUTF8;
begin
FastSetString(result,nil,BinBytes*2);
BinToHexDisplayLower(Bin,pointer(result),BinBytes);
end;
function BinToHexDisplayLowerShort(Bin: PAnsiChar; BinBytes: integer): shortstring;
begin
if BinBytes>127 then
BinBytes := 127;
result[0] := AnsiChar(BinBytes * 2);
BinToHexDisplayLower(Bin,@result[1],BinBytes);
end;
function BinToHexDisplayLowerShort16(Bin: Int64; BinBytes: integer): TShort16;
begin
if BinBytes>8 then
BinBytes := 8;
result[0] := AnsiChar(BinBytes * 2);
BinToHexDisplayLower(@Bin,@result[1],BinBytes);
end;
function BinToHexDisplayFile(Bin: PAnsiChar; BinBytes: integer): TFileName;
{$ifdef UNICODE}
var temp: TSynTempBuffer;
begin
temp.Init(BinBytes*2);
BinToHexDisplayLower(Bin,temp.Buf,BinBytes);
Ansi7ToString(PWinAnsiChar(temp.buf),BinBytes*2,string(result));
temp.Done;
end;
{$else}
begin
SetString(result,nil,BinBytes*2);
BinToHexDisplayLower(Bin,pointer(result),BinBytes);
end;
{$endif UNICODE}
procedure PointerToHex(aPointer: Pointer; var result: RawUTF8);
begin
FastSetString(result,nil,SizeOf(Pointer)*2);
BinToHexDisplay(@aPointer,pointer(result),SizeOf(Pointer));
end;
function PointerToHex(aPointer: Pointer): RawUTF8;
begin
FastSetString(result,nil,SizeOf(aPointer)*2);
BinToHexDisplay(@aPointer,pointer(result),SizeOf(aPointer));
end;
function CardinalToHex(aCardinal: Cardinal): RawUTF8;
begin
FastSetString(result,nil,SizeOf(aCardinal)*2);
BinToHexDisplay(@aCardinal,pointer(result),SizeOf(aCardinal));
end;
function CardinalToHexLower(aCardinal: Cardinal): RawUTF8;
begin
FastSetString(result,nil,SizeOf(aCardinal)*2);
BinToHexDisplayLower(@aCardinal,pointer(result),SizeOf(aCardinal));
end;
function Int64ToHex(aInt64: Int64): RawUTF8;
begin
FastSetString(result,nil,SizeOf(Int64)*2);
BinToHexDisplay(@aInt64,pointer(result),SizeOf(Int64));
end;
procedure Int64ToHex(aInt64: Int64; var result: RawUTF8);
begin
FastSetString(result,nil,SizeOf(Int64)*2);
BinToHexDisplay(@aInt64,pointer(result),SizeOf(Int64));
end;
function PointerToHexShort(aPointer: Pointer): TShort16;
begin
result[0] := AnsiChar(SizeOf(aPointer)*2);
BinToHexDisplay(@aPointer,@result[1],SizeOf(aPointer));
end;
function CardinalToHexShort(aCardinal: Cardinal): TShort16;
begin
result[0] := AnsiChar(SizeOf(aCardinal)*2);
BinToHexDisplay(@aCardinal,@result[1],SizeOf(aCardinal));
end;
function Int64ToHexShort(aInt64: Int64): TShort16;
begin
result[0] := AnsiChar(SizeOf(aInt64)*2);
BinToHexDisplay(@aInt64,@result[1],SizeOf(aInt64));
end;
procedure Int64ToHexShort(aInt64: Int64; out result: TShort16);
begin
result[0] := AnsiChar(SizeOf(aInt64)*2);
BinToHexDisplay(@aInt64,@result[1],SizeOf(aInt64));
end;
function Int64ToHexString(aInt64: Int64): string;
var temp: TShort16;
begin
Int64ToHexShort(aInt64,temp);
Ansi7ToString(@temp[1],ord(temp[0]),result);
end;
function UInt3DigitsToUTF8(Value: Cardinal): RawUTF8;
begin
FastSetString(result,nil,3);
PWordArray(result)[0] := TwoDigitLookupW[Value div 10];
PByteArray(result)[2] := (Value mod 10)+48;
end;
function UInt4DigitsToUTF8(Value: Cardinal): RawUTF8;
begin
FastSetString(result,nil,4);
if Value>9999 then
Value := 9999;
YearToPChar(Value,pointer(result));
end;
function UInt4DigitsToShort(Value: Cardinal): TShort4;
begin
result[0] := #4;
if Value>9999 then
Value := 9999;
YearToPChar(Value,@result[1]);
end;
function UInt3DigitsToShort(Value: Cardinal): TShort4;
begin
if Value>999 then
Value := 999;
YearToPChar(Value,@result[0]);
result[0] := #3; // override first digit
end;
function UInt2DigitsToShort(Value: byte): TShort4;
begin
result[0] := #2;
if Value>99 then
Value := 99;
PWord(@result[1])^ := TwoDigitLookupW[Value];
end;
function UInt2DigitsToShortFast(Value: byte): TShort4;
begin
result[0] := #2;
PWord(@result[1])^ := TwoDigitLookupW[Value];
end;
function SameValue(const A, B: Double; DoublePrec: double): Boolean;
var AbsA,AbsB,Res: double;
begin
if PInt64(@DoublePrec)^=0 then begin // Max(Min(Abs(A),Abs(B))*1E-12,1E-12)
AbsA := Abs(A);
AbsB := Abs(B);
Res := 1E-12;
if AbsA<AbsB then
DoublePrec := AbsA*Res else
DoublePrec := AbsB*Res;
if DoublePrec<Res then
DoublePrec := Res;
end;
if A<B then
result := (B-A)<=DoublePrec else
result := (A-B)<=DoublePrec;
end;
function SameValueFloat(const A, B: TSynExtended; DoublePrec: TSynExtended): Boolean;
var AbsA,AbsB,Res: TSynExtended;
begin
if DoublePrec=0 then begin // Max(Min(Abs(A),Abs(B))*1E-12,1E-12)
AbsA := Abs(A);
AbsB := Abs(B);
Res := 1E-12; // also for TSynExtended (FPC uses 1E-4!)
if AbsA<AbsB then
DoublePrec := AbsA*Res else
DoublePrec := AbsB*Res;
if DoublePrec<Res then
DoublePrec := Res;
end;
if A<B then
result := (B-A)<=DoublePrec else
result := (A-B)<=DoublePrec;
end;
function CompareFloat(const A, B: double): integer;
begin
result := ord(A>B)-ord(A<B);
end;
function CompareInteger(const A, B: integer): integer;
begin
result := ord(A>B)-ord(A<B);
end;
function CompareInt64(const A, B: Int64): integer;
begin
result := ord(A>B)-ord(A<B);
end;
function CompareCardinal(const A, B: cardinal): integer;
begin
result := ord(A>B)-ord(A<B);
end;
procedure KahanSum(const Data: double; var Sum, Carry: double);
var y, t: double;
begin
y := Data - Carry;
t := Sum + y;
Carry := (t - Sum) - y;
Sum := t;
end;
function FindRawUTF8(Values: PRawUTF8; const Value: RawUTF8; ValuesCount: integer;
CaseSensitive: boolean): integer;
var ValueLen: TStrLen;
begin
dec(ValuesCount);
ValueLen := length(Value);
if ValueLen=0 then
for result := 0 to ValuesCount do
if Values^='' then
exit else
inc(Values) else
if CaseSensitive then
for result := 0 to ValuesCount do
if (PtrUInt(Values^)<>0) and
(PStrLen(PtrUInt(Values^)-_STRLEN)^=ValueLen) and
CompareMemFixed(pointer(PtrInt(Values^)),pointer(Value),ValueLen) then
exit else
inc(Values) else
for result := 0 to ValuesCount do
if (PtrUInt(Values^)<>0) and // StrIComp() won't change length
(PStrLen(PtrUInt(Values^)-_STRLEN)^=ValueLen) and
(StrIComp(pointer(Values^),pointer(Value))=0) then
exit else
inc(Values);
result := -1;
end;
function FindPropName(Values: PRawUTF8; const Value: RawUTF8;
ValuesCount: integer): integer;
var ValueLen: TStrLen;
begin
dec(ValuesCount);
ValueLen := length(Value);
if ValueLen=0 then
for result := 0 to ValuesCount do
if Values^='' then
exit else
inc(Values) else
for result := 0 to ValuesCount do
if (PtrUInt(Values^)<>0) and
(PStrLen(PtrUInt(Values^)-_STRLEN)^=ValueLen) and
IdemPropNameUSameLen(pointer(Values^),pointer(Value),ValueLen) then
exit else
inc(Values);
result := -1;
end;
function FindRawUTF8(const Values: TRawUTF8DynArray; const Value: RawUTF8;
CaseSensitive: boolean): integer;
begin
result := FindRawUTF8(pointer(Values),Value,length(Values),CaseSensitive);
end;
function FindRawUTF8(const Values: array of RawUTF8; const Value: RawUTF8;
CaseSensitive: boolean): integer;
begin
result := high(Values);
if result>=0 then
result := FindRawUTF8(@Values[0],Value,result+1,CaseSensitive);
end;
function FindPropName(const Names: array of RawUTF8; const Name: RawUTF8): integer;
begin
result := high(Names);
if result>=0 then
result := FindPropName(@Names[0],Name,result+1);
end;
function AddRawUTF8(var Values: TRawUTF8DynArray; const Value: RawUTF8;
NoDuplicates, CaseSensitive: boolean): boolean;
var i: integer;
begin
if NoDuplicates then begin
i := FindRawUTF8(Values,Value,CaseSensitive);
if i>=0 then begin
result := false;
exit;
end;
end;
i := length(Values);
SetLength(Values,i+1);
Values[i] := Value;
result := true;
end;
function NextGrow(capacity: integer): integer;
begin // algorithm similar to TFPList.Expand for the increasing ranges
result := capacity;
if result<128 shl 20 then
if result<8 shl 20 then
if result<=128 then
if result>8 then
inc(result,16) else
inc(result,4) else
inc(result,result shr 2) else
inc(result,result shr 3) else
inc(result,16 shl 20);
end;
procedure AddRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer;
const Value: RawUTF8);
var capacity: integer;
begin
capacity := Length(Values);
if ValuesCount=capacity then
SetLength(Values,NextGrow(capacity));
Values[ValuesCount] := Value;
inc(ValuesCount);
end;
function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray): boolean;
var n,i: integer;
begin
result := false;
n := length(A);
if n<>length(B) then
exit;
for i := 0 to n-1 do
if A[i]<>B[i] then
exit;
result := true;
end;
function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray; Count: integer): boolean;
var i: integer;
begin
result := false;
for i := 0 to Count - 1 do
if A[i]<>B[i] then
exit;
result := true;
end;
procedure StringDynArrayToRawUTF8DynArray(const Source: TStringDynArray;
var Result: TRawUTF8DynArray);
var i: Integer;
begin
Finalize(result);
SetLength(Result,length(Source));
for i := 0 to length(Source)-1 do
StringToUTF8(Source[i],Result[i]);
end;
procedure StringListToRawUTF8DynArray(Source: TStringList; var Result: TRawUTF8DynArray);
var i: Integer;
begin
Finalize(result);
SetLength(Result,Source.Count);
for i := 0 to Source.Count-1 do
StringToUTF8(Source[i],Result[i]);
end;
function FindSectionFirstLine(var source: PUTF8Char; search: PAnsiChar): boolean;
{$ifdef PUREPASCAL}
var tab: PTextCharSet;
begin
result := false;
if source=nil then
exit;
repeat
if source^='[' then begin
inc(source);
result := IdemPChar(source,search);
end;
tab := @TEXT_CHARS;
while tcNot01013 in tab[source^] do inc(source);
while tc1013 in tab[source^] do inc(source);
if result then
exit; // found
until source^=#0;
source := nil;
end;
{$else} {$ifdef FPC} nostackframe; assembler; {$endif}
asm // eax=source edx=search
push eax // save source var
mov eax, [eax] // eax=source
test eax, eax
jz @z
push ebx
mov ebx, edx // save search
cmp byte ptr[eax], '['
lea eax, [eax + 1]
jne @s
@i: push eax
mov edx, ebx // edx=search
call IdemPChar
pop ecx // ecx=source
jmp @1
@s: mov ecx, eax
xor eax, eax // result := false
@1: mov dl, [ecx] // while not (source^ in [#0,#10,#13]) do inc(source);
inc ecx
cmp dl, 13
ja @1
je @e
or dl, dl
jz @0
cmp dl, 10
jne @1
cmp byte[ecx], 13
jbe @1
jmp @4
@e: cmp byte ptr[ecx], 10 // jump #13#10
jne @4
inc ecx
@4: test al, al
jnz @x // exit if IdemPChar returned true
cmp byte ptr[ecx], '['
lea ecx, [ecx + 1]
jne @1
mov eax, ecx
jmp @i
@0: xor ecx, ecx // set source=nil
@x: pop ebx
pop edx // restore source var
mov [edx], ecx // update source var
ret
@z: pop edx // ignore source var, result := false
end;
{$endif PUREPASCAL}
{$ifdef USENORMTOUPPER}
{$ifdef PUREPASCAL}
function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean;
begin
result := false;
if (p=nil) or (up=nil) then
exit;
while up^<>#0 do begin
if (p^>#255) or (up^<>AnsiChar(NormToUpperByte[ord(p^)])) then
exit;
inc(up);
inc(p);
end;
result := true;
end;
{$else}
function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean; {$ifdef FPC} nostackframe; assembler; {$endif}
asm // eax=p edx=up
test eax, eax
jz @e // P=nil -> false
test edx, edx
push ebx
push esi
jz @z // up=nil -> true
mov esi, offset NormToUpper
xor ebx, ebx
xor ecx, ecx
@1: mov bx, [eax] // bl=p^
mov cl, [edx] // cl=up^
test bh, bh // p^ > #255 -> FALSE
jnz @n
test cl, cl
mov bl, [ebx + esi] // bl=NormToUpper[p^]
jz @z // up^=#0 -> OK
inc edx
add eax, 2
cmp bl, cl
je @1
@n: pop esi
pop ebx
@e: xor eax, eax
ret
@z: mov al, 1 // up^=#0 -> OK
pop esi
pop ebx
end;
{$endif PUREPASCAL}
{$else}
function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean;
// if the beginning of p^ is same as up^ (ignore case - up^ must be already Upper)
begin
result := false;
if (p=nil) or (up=nil) then
exit;
while up^<>#0 do begin
if (p^>#255) or (up^<>AnsiChar(NormToUpperByteAnsi7[ord(p^)])) then
exit;
inc(up);
inc(p);
end;
result := true;
end;
{$endif USENORMTOUPPER}
function FindNameValue(P: PUTF8Char; UpperName: PAnsiChar): PUTF8Char;
var
{$ifdef CPUX86NOTPIC}
table: TNormTable absolute NormToUpperAnsi7;
{$else}
table: PNormTable;
{$endif}
c: AnsiChar;
u: PAnsiChar;
label
_0;
begin
if (P = nil) or (UpperName = nil) then
goto _0;
{$ifndef CPUX86NOTPIC} table := @NormToUpperAnsi7; {$endif}
repeat
c := UpperName^;
if table[P^] = c then
begin
inc(P);
u := UpperName + 1;
repeat
c := u^;
inc(u);
if c <> #0 then
begin
if table[P^] <> c then
break;
inc(P);
continue;
end;
result := P; // if found, points just after UpperName
exit;
until false;
end;
repeat
repeat
c := P^;
inc(P);
until c <= #13;
if c = #13 then // most common case is text ending with #13#10
repeat
c := P^;
if (c <> #10) and (c <> #13) then
break;
inc(P);
until false
else if c <> #10 then
if c <> #0 then
continue // e.g. #9
else
goto _0
else
repeat
c := P^;
if c <> #10 then
break;
inc(P);
until false;
if c <> #0 then
break; // check if UpperName is at the begining of the new line
_0: result := nil; // reached P^=#0 -> not found
exit;
until false;
until false;
end;
function FindNameValue(const NameValuePairs: RawUTF8; UpperName: PAnsiChar;
var Value: RawUTF8): boolean;
var
P: PUTF8Char;
L: PtrInt;
begin
P := FindNameValue(pointer(NameValuePairs), UpperName);
if P <> nil then
begin
while P^ in [#9, ' '] do // trim left
inc(P);
L := 0;
while P[L] > #13 do // end of line/value
inc(L);
while P[L - 1] = ' ' do // trim right
dec(L);
FastSetString(Value, P, L);
result := true;
end
else
begin
{$ifdef FPC} Finalize(Value); {$else} Value := ''; {$endif}
result := false;
end;
end;
function FindSectionFirstLineW(var source: PWideChar; search: PUTF8Char): boolean;
{$ifdef PUREPASCAL}
begin
result := false;
if source=nil then
exit;
repeat
if source^='[' then begin
inc(source);
result := IdemPCharW(source,search);
end;
while not (cardinal(source^) in [0,10,13]) do inc(source);
while cardinal(source^) in [10,13] do inc(source);
if result then
exit; // found
until source^=#0;
source := nil;
end;
{$else} {$ifdef FPC} nostackframe; assembler; {$endif}
asm // eax=source edx=search
push eax // save source var
mov eax, [eax] // eax=source
test eax, eax
jz @z
push ebx
mov ebx, edx // save search
cmp word ptr[eax], '['
lea eax, [eax + 2]
jne @s
@i: push eax
mov edx, ebx // edx=search
call IdemPCharW
pop ecx // ecx=source
jmp @1
@s: mov ecx, eax
xor eax, eax // result := false
@1: mov dx, [ecx] // while not (source^ in [#0,#10,#13]) do inc(source)
add ecx, 2
cmp dx, 13
ja @1
je @e
or dx, dx
jz @0
cmp dx, 10
jne @1
jmp @4
@e: cmp word ptr[ecx], 10 // jump #13#10
jne @4
add ecx, 2
@4: test al, al
jnz @x // exit if IdemPChar returned true
cmp word ptr[ecx], '['
lea ecx, [ecx + 2]
jne @1
mov eax, ecx
jmp @i
@0: xor ecx, ecx // set source=nil
@x: pop ebx
pop edx // restore source var
mov [edx], ecx // update source var
ret
@z: pop edx // ignore source var, result := false
end;
{$endif PUREPASCAL}
function FindIniNameValue(P: PUTF8Char; UpperName: PAnsiChar): RawUTF8;
var u, PBeg: PUTF8Char;
by4: cardinal;
table: {$ifdef CPUX86NOTPIC}TNormTable absolute NormToUpperAnsi7{$else}PNormTable{$endif};
begin // expect UpperName as 'NAME='
if (P<>nil) and (P^<>'[') and (UpperName<>nil) then begin
{$ifndef CPUX86NOTPIC}table := @NormToUpperAnsi7;{$endif}
PBeg := nil;
u := P;
repeat
while u^=' ' do inc(u); // trim left ' '
if u^=#0 then
break;
if table[u^]=UpperName[0] then
PBeg := u;
repeat
by4 := PCardinal(u)^;
if ToByte(by4)>13 then
if ToByte(by4 shr 8)>13 then
if ToByte(by4 shr 16)>13 then
if ToByte(by4 shr 24)>13 then begin
inc(u,4);
continue;
end else
inc(u,3) else
inc(u,2) else
inc(u);
if u^ in [#0,#10,#13] then
break else
inc(u);
until false;
if PBeg<>nil then begin
inc(PBeg);
P := u;
u := pointer(UpperName+1);
repeat
if u^<>#0 then
if table[PBeg^]<>u^ then
break else begin
inc(u);
inc(PBeg);
end else begin
FastSetString(result,PBeg,P-PBeg);
exit;
end;
until false;
PBeg := nil;
u := P;
end;
if u^=#13 then inc(u);
if u^=#10 then inc(u);
until u^ in [#0,'['];
end;
result := '';
end;
function ExistsIniName(P: PUTF8Char; UpperName: PAnsiChar): boolean;
var table: PNormTable;
begin
result := false;
table := @NormToUpperAnsi7;
if (P<>nil) and (P^<>'[') then
repeat
if P^=' ' then begin
repeat inc(P) until P^<>' '; // trim left ' '
if P^=#0 then
break;
end;
if IdemPChar2(table,P,UpperName) then begin
result := true;
exit;
end;
repeat
if P[0]>#13 then
if P[1]>#13 then
if P[2]>#13 then
if P[3]>#13 then begin
inc(P,4);
continue;
end else
inc(P,3) else
inc(P,2) else
inc(P);
case P^ of
#0: exit;
#10: begin inc(P); break; end;
#13: begin if P[1]=#10 then inc(P,2) else inc(P); break; end;
else inc(P);
end;
until false;
until P^='[';
end;
function ExistsIniNameValue(P: PUTF8Char; const UpperName: RawUTF8;
const UpperValues: array of PAnsiChar): boolean;
var PBeg: PUTF8Char;
begin
result := true;
if high(UpperValues)>=0 then
while (P<>nil) and (P^<>'[') do begin
if P^=' ' then repeat inc(P) until P^<>' '; // trim left ' '
PBeg := P;
if IdemPChar(PBeg,pointer(UpperName)) then begin
inc(PBeg,length(UpperName));
if IdemPCharArray(PBeg,UpperValues)>=0 then
exit; // found one value
break;
end;
P := GotoNextLine(P);
end;
result := false;
end;
function GetSectionContent(SectionFirstLine: PUTF8Char): RawUTF8;
var PBeg: PUTF8Char;
begin
PBeg := SectionFirstLine;
while (SectionFirstLine<>nil) and (SectionFirstLine^<>'[') do
SectionFirstLine := GotoNextLine(SectionFirstLine);
if SectionFirstLine=nil then
result := PBeg else
FastSetString(result,PBeg,SectionFirstLine-PBeg);
end;
function GetSectionContent(const Content, SectionName: RawUTF8): RawUTF8;
var P: PUTF8Char;
UpperSection: array[byte] of AnsiChar;
begin
P := pointer(Content);
PWord(UpperCopy255(UpperSection,SectionName))^ := ord(']');
if FindSectionFirstLine(P,UpperSection) then
result := GetSectionContent(P) else
result := '';
end;
function DeleteSection(var Content: RawUTF8; const SectionName: RawUTF8;
EraseSectionHeader: boolean): boolean;
var P: PUTF8Char;
UpperSection: array[byte] of AnsiChar;
begin
result := false; // no modification
P := pointer(Content);
PWord(UpperCopy255(UpperSection,SectionName))^ := ord(']');
if FindSectionFirstLine(P,UpperSection) then
result := DeleteSection(P,Content,EraseSectionHeader);
end;
function DeleteSection(SectionFirstLine: PUTF8Char; var Content: RawUTF8;
EraseSectionHeader: boolean): boolean;
var PEnd: PUTF8Char;
IndexBegin: PtrInt;
begin
result := false;
PEnd := SectionFirstLine;
if EraseSectionHeader then // erase [Section] header line
while (PtrUInt(SectionFirstLine)>PtrUInt(Content)) and (SectionFirstLine^<>'[') do dec(SectionFirstLine);
while (PEnd<>nil) and (PEnd^<>'[') do
PEnd := GotoNextLine(PEnd);
IndexBegin := SectionFirstLine-pointer(Content);
if IndexBegin=0 then
exit; // no modification
if PEnd=nil then
SetLength(Content,IndexBegin) else
delete(Content,IndexBegin+1,PEnd-SectionFirstLine);
result := true; // Content was modified
end;
procedure ReplaceSection(SectionFirstLine: PUTF8Char;
var Content: RawUTF8; const NewSectionContent: RawUTF8);
var PEnd: PUTF8Char;
IndexBegin: PtrInt;
begin
if SectionFirstLine=nil then
exit;
// delete existing [Section] content
PEnd := SectionFirstLine;
while (PEnd<>nil) and (PEnd^<>'[') do
PEnd := GotoNextLine(PEnd);
IndexBegin := SectionFirstLine-pointer(Content);
if PEnd=nil then
SetLength(Content,IndexBegin) else
delete(Content,IndexBegin+1,PEnd-SectionFirstLine);
// insert section content
insert(NewSectionContent,Content,IndexBegin+1);
end;
procedure ReplaceSection(var Content: RawUTF8; const SectionName,
NewSectionContent: RawUTF8);
var UpperSection: array[byte] of AnsiChar;
P: PUTF8Char;
begin
P := pointer(Content);
PWord(UpperCopy255(UpperSection,SectionName))^ := ord(']');
if FindSectionFirstLine(P,UpperSection) then
ReplaceSection(P,Content,NewSectionContent) else
Content := Content+'['+SectionName+']'#13#10+NewSectionContent;
end;
function FindIniNameValueInteger(P: PUTF8Char; UpperName: PAnsiChar): PtrInt;
begin
result := GetInteger(pointer(FindIniNameValue(P,UpperName)));
end;
function FindIniEntry(const Content, Section, Name: RawUTF8): RawUTF8;
var P: PUTF8Char;
UpperSection, UpperName: array[byte] of AnsiChar;
// possible GPF if length(Section/Name)>255, but should const in code
begin
result := '';
P := pointer(Content);
if P=nil then exit;
// UpperName := UpperCase(Name)+'=';
PWord(UpperCopy255(UpperName,Name))^ := ord('=');
if Section='' then
// find the Name= entry before any [Section]
result := FindIniNameValue(P,UpperName) else begin
// find the Name= entry in the specified [Section]
PWord(UpperCopy255(UpperSection,Section))^ := ord(']');
if FindSectionFirstLine(P,UpperSection) then
result := FindIniNameValue(P,UpperName);
end;
end;
function FindWinAnsiIniEntry(const Content, Section,Name: RawUTF8): RawUTF8;
begin
result := WinAnsiToUtf8(WinAnsiString(FindIniEntry(Content,Section,Name)));
end;
function FindIniEntryInteger(const Content,Section,Name: RawUTF8): integer;
begin
result := GetInteger(pointer(FindIniEntry(Content,Section,Name)));
end;
function FindIniEntryFile(const FileName: TFileName; const Section,Name: RawUTF8): RawUTF8;
var Content: RawUTF8;
begin
Content := StringFromFile(FileName);
if Content='' then
result := '' else
result := FindIniEntry(Content,Section,Name);
end;
function UpdateIniNameValueInternal(var Content: RawUTF8;
const NewValue, NewValueCRLF: RawUTF8; var P: PUTF8Char;
UpperName: PAnsiChar; UpperNameLength: integer): boolean;
var PBeg: PUTF8Char;
i: integer;
begin
while (P<>nil) and (P^<>'[') do begin
while P^=' ' do inc(P); // trim left ' '
PBeg := P;
P := GotoNextLine(P);
if IdemPChar(PBeg,UpperName) then begin
// update Name=Value entry
result := true;
inc(PBeg,UpperNameLength);
i := (PBeg-pointer(Content))+1;
if (i=length(NewValue)) and CompareMem(PBeg,pointer(NewValue),i) then
exit; // new Value is identical to the old one -> no change
if P=nil then // avoid last line (P-PBeg) calculation error
SetLength(Content,i-1) else
delete(Content,i,P-PBeg); // delete old Value
insert(NewValueCRLF,Content,i); // set new value
exit;
end;
end;
result := false;
end;
function UpdateIniNameValue(var Content: RawUTF8; const Name, UpperName, NewValue: RawUTF8): boolean;
var P: PUTF8Char;
begin
if UpperName='' then
result := false else begin
P := pointer(Content);
result := UpdateIniNameValueInternal(Content,NewValue,NewValue+#13#10,P,
pointer(UpperName),length(UpperName));
if result or (Name='') then
exit;
if Content<>'' then
Content := Content+#13#10;
Content := Content+Name+NewValue;
result := true;
end;
end;
procedure UpdateIniEntry(var Content: RawUTF8; const Section,Name,Value: RawUTF8);
const CRLF = #13#10;
var P: PUTF8Char;
SectionFound: boolean;
i, UpperNameLength: PtrInt;
V: RawUTF8;
UpperSection, UpperName: array[byte] of AnsiChar;
label Sec;
begin
UpperNameLength := length(Name);
PWord(UpperCopy255Buf(UpperName,pointer(Name),UpperNameLength))^ := ord('=');
inc(UpperNameLength);
V := Value+CRLF;
P := pointer(Content);
// 1. find Section, and try update within it
if Section='' then
goto Sec; // find the Name= entry before any [Section]
SectionFound := false;
PWord(UpperCopy255(UpperSection,Section))^ := ord(']');
if FindSectionFirstLine(P,UpperSection) then begin
Sec:SectionFound := true;
if UpdateIniNameValueInternal(Content,Value,V,P,@UpperName,UpperNameLength) then
exit;
// we reached next [Section] without having found Name=
end;
// 2. section or Name= entry not found: add Name=Value
V := Name+'='+V;
if not SectionFound then
// create not existing [Section]
V := '['+Section+(']'+CRLF)+V;
// insert Name=Value at P^ (end of file or end of [Section])
if P=nil then
// insert at end of file
Content := Content+V else begin
// insert at end of [Section]
i := (P-pointer(Content))+1;
insert(V,Content,i);
end;
end;
procedure UpdateIniEntryFile(const FileName: TFileName; const Section,Name,Value: RawUTF8);
var Content: RawUTF8;
begin
Content := StringFromFile(FileName);
UpdateIniEntry(Content,Section,Name,Value);
FileFromString(Content,FileName);
end;
function StringFromFile(const FileName: TFileName; HasNoSize: boolean): RawByteString;
var F: THandle;
Read, Size, Chunk: integer;
P: PUTF8Char;
tmp: array[0..$7fff] of AnsiChar;
begin
result := '';
if FileName='' then
exit;
F := FileOpenSequentialRead(FileName);
if PtrInt(F)>=0 then begin
if HasNoSize then begin
Size := 0;
repeat
Read := FileRead(F,tmp,SizeOf(tmp));
if Read<=0 then
break;
SetLength(result,Size+Read); // in-place resize
MoveFast(tmp,PByteArray(result)^[Size],Read);
inc(Size,Read);
until false;
end else begin
Size := GetFileSize(F,nil);
if Size>0 then begin
SetLength(result,Size);
P := pointer(result);
repeat
Chunk := Size;
{$ifdef MSWINDOWS} // FILE_FLAG_SEQUENTIAL_SCAN has limits on XP
if Chunk>32 shl 20 then
Chunk := 32 shl 20; // avoid e.g. ERROR_NO_SYSTEM_RESOURCES
{$endif}
Read := FileRead(F,P^,Chunk);
if Read<=0 then begin
result := '';
break;
end;
inc(P,Read);
dec(Size,Read);
until Size=0;
end;
end;
FileClose(F);
end;
end;
function FileFromString(const Content: RawByteString; const FileName: TFileName;
FlushOnDisk: boolean; FileDate: TDateTime): boolean;
var F: THandle;
P: PByte;
L,written: integer;
begin
result := false;
if FileName='' then
exit;
F := FileCreate(FileName);
if PtrInt(F)<0 then
exit;
L := length(Content);
P := pointer(Content);
while L>0 do begin
written := FileWrite(F,P^,L);
if written<0 then begin
FileClose(F);
exit;
end;
dec(L,written);
inc(P,written);
end;
if FlushOnDisk then
FlushFileBuffers(F);
{$ifdef MSWINDOWS}
if FileDate<>0 then
FileSetDate(F,DateTimeToFileDate(FileDate));
FileClose(F);
{$else}
FileClose(F);
if FileDate<>0 then
FileSetDate(FileName,DateTimeToFileDate(FileDate));
{$endif MSWINDOWS}
result := true;
end;
type
TTextFileKind = (isUnicode, isUTF8, isAnsi);
function TextFileKind(const Map: TMemoryMap): TTextFileKind;
begin
result := isAnsi;
if (Map.Buffer<>nil) and (Map.Size>3) then
if PWord(Map.Buffer)^=$FEFF then
result := isUnicode else
if (PWord(Map.Buffer)^=$BBEF) and (PByteArray(Map.Buffer)[2]=$BF) then
result := isUTF8;
end;
function AnyTextFileToSynUnicode(const FileName: TFileName; ForceUTF8: boolean): SynUnicode;
var Map: TMemoryMap;
begin
result := '';
if Map.Map(FileName) then
try
if ForceUTF8 then
UTF8ToSynUnicode(PUTF8Char(Map.Buffer),Map.Size,Result) else
case TextFileKind(Map) of
isUnicode:
SetString(result,PWideChar(PtrUInt(Map.Buffer)+2),(Map.Size-2) shr 1);
isUTF8:
UTF8ToSynUnicode(PUTF8Char(pointer(PtrUInt(Map.Buffer)+3)),Map.Size-3,Result);
isAnsi:
result := CurrentAnsiConvert.AnsiToUnicodeString(Map.Buffer, Map.Size);
end;
finally
Map.UnMap;
end;
end;
function AnyTextFileToRawUTF8(const FileName: TFileName; AssumeUTF8IfNoBOM: boolean): RawUTF8;
var Map: TMemoryMap;
begin
result := '';
if Map.Map(FileName) then
try
case TextFileKind(Map) of
isUnicode:
RawUnicodeToUtf8(PWideChar(PtrUInt(Map.Buffer)+2),(Map.Size-2) shr 1,Result);
isUTF8:
FastSetString(result,pointer(PtrUInt(Map.Buffer)+3),Map.Size-3);
isAnsi:
if AssumeUTF8IfNoBOM then
FastSetString(result,Map.Buffer,Map.Size) else
result := CurrentAnsiConvert.AnsiBufferToRawUTF8(Map.Buffer, Map.Size);
end;
finally
Map.UnMap;
end;
end;
function AnyTextFileToString(const FileName: TFileName; ForceUTF8: boolean): string;
var Map: TMemoryMap;
begin
result := '';
if Map.Map(FileName) then
try
if ForceUTF8 then
{$ifdef UNICODE}
UTF8DecodeToString(PUTF8Char(Map.Buffer),Map.Size,result) {$else}
result := CurrentAnsiConvert.UTF8BufferToAnsi(PUTF8Char(Map.Buffer),Map.Size)
{$endif} else
case TextFileKind(Map) of
{$ifdef UNICODE}
isUnicode:
SetString(result,PWideChar(PtrUInt(Map.Buffer)+2),(Map.Size-2) shr 1);
isUTF8:
UTF8DecodeToString(pointer(PtrUInt(Map.Buffer)+3),Map.Size-3,result);
isAnsi:
result := CurrentAnsiConvert.AnsiToUnicodeString(Map.Buffer,Map.Size);
{$else}
isUnicode:
result := CurrentAnsiConvert.UnicodeBufferToAnsi(PWideChar(PtrUInt(Map.Buffer)+2),(Map.Size-2) shr 1);
isUTF8:
result := CurrentAnsiConvert.UTF8BufferToAnsi(pointer(PtrUInt(Map.Buffer)+3),Map.Size-3);
isAnsi:
SetString(result,PAnsiChar(Map.Buffer),Map.Size);
{$endif UNICODE}
end;
finally
Map.UnMap;
end;
end;
function StreamToRawByteString(aStream: TStream): RawByteString;
var current, size: Int64;
begin
result := '';
if aStream=nil then
exit;
current := aStream.Position;
if (current=0) and aStream.InheritsFrom(TRawByteStringStream) then begin
result := TRawByteStringStream(aStream).DataString; // fast COW
exit;
end;
size := aStream.Size-current;
if (size=0) or (size>maxInt) then
exit;
SetLength(result,size);
aStream.Read(pointer(result)^,size);
aStream.Position := current;
end;
function RawByteStringToStream(const aString: RawByteString): TStream;
begin
result := TRawByteStringStream.Create(aString);
end;
function ReadStringFromStream(S: TStream; MaxAllowedSize: integer): RawUTF8;
var L: integer;
begin
result := '';
L := 0;
if (S.Read(L,4)<>4) or (L<=0) or (L>MaxAllowedSize) then
exit;
FastSetString(result,nil,L);
if S.Read(pointer(result)^,L)<>L then
result := '';
end;
function WriteStringToStream(S: TStream; const Text: RawUTF8): boolean;
var L: integer;
begin
L := length(Text);
if L=0 then
result := S.Write(L,4)=4 else
{$ifdef FPC}
result := (S.Write(L,4)=4) and (S.Write(pointer(Text)^,L)=L);
{$else}
result := S.Write(pointer(PtrInt(Text)-SizeOf(integer))^,L+4)=L+4;
{$endif FPC}
end;
function GetFileNameWithoutExt(const FileName: TFileName;
Extension: PFileName): TFileName;
var i, max: PtrInt;
begin
i := length(FileName);
max := i-16;
while (i>0) and not(cardinal(FileName[i]) in [ord('\'),ord('/'),ord('.')])
and (i>=max) do dec(i);
if (i=0) or (FileName[i]<>'.') then begin
result := FileName;
if Extension<>nil then
Extension^ := '';
end else begin
result := copy(FileName,1,i-1);
if Extension<>nil then
Extension^ := copy(FileName,i,20);
end;
end;
function GetFileNameExtIndex(const FileName, CSVExt: TFileName): integer;
var Ext: TFileName;
P: PChar;
begin
result := -1;
P := pointer(CSVExt);
Ext := ExtractFileExt(FileName);
if (P=nil) or (Ext='') or (Ext[1]<>'.') then
exit;
delete(Ext,1,1);
repeat
inc(result);
if SameText(GetNextItemString(P),Ext) then
exit;
until P=nil;
result := -1;
end;
function FileSize(const FileName: TFileName): Int64;
{$ifdef MSWINDOWS}
var FA: WIN32_FILE_ATTRIBUTE_DATA;
begin // 5 times faster than CreateFile, GetFileSizeEx, CloseHandle
if GetFileAttributesEx(pointer(FileName),GetFileExInfoStandard,@FA) then begin
PInt64Rec(@result)^.Lo := FA.nFileSizeLow;
PInt64Rec(@result)^.Hi := FA.nFileSizeHigh;
end else
result := 0;
end;
{$else}
var f: THandle;
res: Int64Rec absolute result;
begin
result := 0;
f := FileOpen(FileName,fmOpenRead or fmShareDenyNone);
if PtrInt(f)>0 then begin
res.Lo := GetFileSize(f,@res.Hi); // from SynKylix/SynFPCLinux
FileClose(f);
end;
end;
{$endif MSWINDOWS}
function FileSize(F: THandle): Int64;
var res: Int64Rec absolute result;
begin
result := 0;
if PtrInt(F)>0 then
res.Lo := GetFileSize(F,@res.Hi); // from WinAPI or SynKylix/SynFPCLinux
end;
function FileInfoByHandle(aFileHandle: THandle; out FileId, FileSize,
LastWriteAccess, FileCreateDateTime: Int64): Boolean;
var
lastreadaccess: TUnixMSTime;
{$ifdef MSWINDOWS}
lp: TByHandleFileInformation;
{$else}
lp: {$ifdef FPC}stat{$else}TStatBuf64{$endif};
r: integer;
{$endif MSWINDOWS}
begin
{$ifdef MSWINDOWS}
result := GetFileInformationByHandle(aFileHandle,lp);
if not result then
exit;
LastWriteAccess := FileTimeToUnixMSTime(lp.ftLastWriteTime);
FileCreateDateTime := FileTimeToUnixMSTime(lp.ftCreationTime);
lastreadaccess := FileTimeToUnixMSTime(lp.ftLastAccessTime);
PInt64Rec(@FileSize).lo := lp.nFileSizeLow;
PInt64Rec(@FileSize).hi := lp.nFileSizeHigh;
PInt64Rec(@FileId).lo := lp.nFileIndexLow;
PInt64Rec(@FileId).hi := lp.nFileIndexHigh;
{$else}
r := {$ifdef FPC}FpFStat{$else}fstat64{$endif}(aFileHandle, lp);
result := r >= 0;
if not result then
exit;
FileId := lp.st_ino;
FileSize := lp.st_size;
lastreadaccess := lp.st_atime * MSecsPerSec;
LastWriteAccess := lp.st_mtime * MSecsPerSec;
{$ifdef OPENBSD}
if (lp.st_birthtime <> 0) and (lp.st_birthtime < lp.st_ctime) then
lp.st_ctime:= lp.st_birthtime;
{$endif}
FileCreateDateTime := lp.st_ctime * MSecsPerSec;
{$endif MSWINDOWS}
if LastWriteAccess <> 0 then
if (FileCreateDateTime = 0) or (FileCreateDateTime > LastWriteAccess) then
FileCreateDateTime:= LastWriteAccess;
if lastreadaccess <> 0 then
if (FileCreateDateTime = 0) or (FileCreateDateTime > lastreadaccess) then
FileCreateDateTime:= lastreadaccess;
end;
function FileAgeToDateTime(const FileName: TFileName): TDateTime;
{$ifdef MSWINDOWS}
var FA: WIN32_FILE_ATTRIBUTE_DATA;
ST,LT: TSystemTime;
begin // 5 times faster than CreateFile, GetFileSizeEx, CloseHandle
if GetFileAttributesEx(pointer(FileName),GetFileExInfoStandard,@FA) and
FileTimeToSystemTime(FA.ftLastWriteTime,ST) and
SystemTimeToTzSpecificLocalTime(nil,ST,LT) then
result := SystemTimeToDateTime(LT) else
result := 0;
end;
{$else}
{$ifdef HASNEWFILEAGE}
begin
if not FileAge(FileName,result) then
{$else}
var Age: integer;
begin
Age := FileAge(FileName);
if Age<>-1 then
result := FileDateToDateTime(Age) else
{$endif HASNEWFILEAGE}
result := 0;
end;
{$endif MSWINDOWS}
function CopyFile(const Source, Target: TFileName; FailIfExists: boolean): boolean;
{$ifdef MSWINDOWS}
begin
result := Windows.CopyFile(pointer(Source),pointer(Target),FailIfExists);
end;
{$else}
var SourceF, DestF: TFileStream;
begin
result := false;
if FailIfExists then
if FileExists(Target) then
exit else
DeleteFile(Target);
try
SourceF := TFileStream.Create(Source,fmOpenRead);
try
DestF := TFileStream.Create(Target,fmCreate);
try
DestF.CopyFrom(SourceF, SourceF.Size);
finally
DestF.Free;
end;
FileSetDateFrom(Target,SourceF.Handle);
finally
SourceF.Free;
end;
result := true;
except
result := false;
end;
end;
{$endif}
function SearchRecToDateTime(const F: TSearchRec): TDateTime;
begin
{$ifdef ISDELPHIXE}
result := F.Timestamp;
{$else}
result := FileDateToDateTime(F.Time);
{$endif}
end;
function SearchRecValidFile(const F: TSearchRec): boolean;
begin
{$ifndef DELPHI5OROLDER}
{$WARN SYMBOL_DEPRECATED OFF} // for faVolumeID
{$endif}
result := (F.Name<>'') and (F.Attr and (faDirectory
{$ifdef MSWINDOWS}+faVolumeID+faSysFile+faHidden)=0) and (F.Name[1]<>'.')
{$else})=0){$endif};
{$ifndef DELPHI5OROLDER}
{$WARN SYMBOL_DEPRECATED ON}
{$endif}
end;
function SearchRecValidFolder(const F: TSearchRec): boolean;
begin
result := (F.Attr and (faDirectory {$ifdef MSWINDOWS}+faHidden{$endif})=faDirectory) and
(F.Name<>'') and (F.Name<>'.') and (F.Name<>'..');
end;
function DirectoryDelete(const Directory: TFileName; const Mask: TFileName;
DeleteOnlyFilesNotDirectory: Boolean; DeletedCount: PInteger): Boolean;
var F: TSearchRec;
Dir: TFileName;
n: integer;
begin
n := 0;
result := true;
if DirectoryExists(Directory) then begin
Dir := IncludeTrailingPathDelimiter(Directory);
if FindFirst(Dir+Mask,faAnyFile-faDirectory,F)=0 then begin
repeat
if SearchRecValidFile(F) then
if DeleteFile(Dir+F.Name) then
inc(n) else
result := false;
until FindNext(F)<>0;
FindClose(F);
end;
if not DeleteOnlyFilesNotDirectory and not RemoveDir(Dir) then
result := false;
end;
if DeletedCount<>nil then
DeletedCount^ := n;
end;
function DirectoryDeleteOlderFiles(const Directory: TFileName; TimePeriod: TDateTime;
const Mask: TFileName; Recursive: Boolean; TotalSize: PInt64): Boolean;
var F: TSearchRec;
Dir: TFileName;
old: TDateTime;
begin
if not Recursive and (TotalSize<>nil) then
TotalSize^ := 0;
result := true;
if (Directory='') or not DirectoryExists(Directory) then
exit;
Dir := IncludeTrailingPathDelimiter(Directory);
if FindFirst(Dir+Mask,faAnyFile,F)=0 then begin
old := Now - TimePeriod;
repeat
if F.Name[1]<>'.' then
if Recursive and (F.Attr and faDirectory<>0) then
DirectoryDeleteOlderFiles(Dir+F.Name,TimePeriod,Mask,true,TotalSize) else
if SearchRecValidFile(F) and (SearchRecToDateTime(F) < old) then
if not DeleteFile(Dir+F.Name) then
result := false else
if TotalSize<>nil then
inc(TotalSize^,F.Size);
until FindNext(F)<>0;
FindClose(F);
end;
end;
procedure TFindFiles.FromSearchRec(const Directory: TFileName; const F: TSearchRec);
begin
Name := Directory+F.Name;
{$ifdef MSWINDOWS}
{$ifdef HASINLINE} // FPC or Delphi 2006+
Size := F.Size;
{$else} // F.Size was limited to 32-bit on older Delphi
PInt64Rec(@Size)^.Lo := F.FindData.nFileSizeLow;
PInt64Rec(@Size)^.Hi := F.FindData.nFileSizeHigh;
{$endif}
{$else}
Size := F.Size;
{$endif}
Attr := F.Attr;
Timestamp := SearchRecToDateTime(F);
end;
function TFindFiles.ToText: shortstring;
begin
FormatShort('% % %',[Name,KB(Size),DateTimeToFileShort(Timestamp)],result);
end;
function FindFiles(const Directory,Mask,IgnoreFileName: TFileName;
SortByName,IncludesDir,SubFolder: boolean): TFindFilesDynArray;
var m,count: integer;
dir: TFileName;
da: TDynArray;
masks: TRawUTF8DynArray;
masked: TFindFilesDynArray;
procedure SearchFolder(const folder : TFileName);
var
F: TSearchRec;
ff: TFindFiles;
begin
if FindFirst(dir+folder+Mask,faAnyfile-faDirectory,F)=0 then begin
repeat
if SearchRecValidFile(F) and ((IgnoreFileName='') or
(AnsiCompareFileName(F.Name,IgnoreFileName)<>0)) then begin
if IncludesDir then
ff.FromSearchRec(dir+folder,F) else
ff.FromSearchRec(folder,F);
da.Add(ff);
end;
until FindNext(F)<>0;
FindClose(F);
end;
if SubFolder and (FindFirst(dir+folder+'*',faDirectory,F)=0) then begin
repeat
if SearchRecValidFolder(F) and ((IgnoreFileName='') or
(AnsiCompareFileName(F.Name,IgnoreFileName)<>0)) then
SearchFolder(IncludeTrailingPathDelimiter(folder+F.Name));
until FindNext(F)<>0;
FindClose(F);
end;
end;
begin
result := nil;
da.Init(TypeInfo(TFindFilesDynArray),result,@count);
if Pos(';',Mask)>0 then
CSVToRawUTF8DynArray(pointer(StringToUTF8(Mask)),masks,';');
if masks<>nil then begin
if SortByName then
QuickSortRawUTF8(masks,length(masks),nil,{$ifdef MSWINDOWS}@StrIComp{$else}@StrComp{$endif});
for m := 0 to length(masks)-1 do begin // masks[] recursion
masked := FindFiles(Directory,UTF8ToString(masks[m]),
IgnoreFileName,SortByName,IncludesDir,SubFolder);
da.AddArray(masked);
end;
end else begin
if Directory<>'' then
dir := IncludeTrailingPathDelimiter(Directory);
SearchFolder('');
if SortByName and (da.Count>0) then
da.Sort(SortDynArrayFileName);
end;
da.Capacity := count; // trim result[]
end;
function FindFilesDynArrayToFileNames(const Files: TFindFilesDynArray): TFileNameDynArray;
var i,n: PtrInt;
begin
Finalize(result);
n := length(Files);
SetLength(result,n);
for i := 0 to n-1 do
result[i] := Files[i].Name;
end;
function SynchFolders(const Reference, Dest: TFileName;
SubFolder,ByContent,WriteFileNameToConsole: boolean): integer;
var ref,dst: TFileName;
fref,fdst: TSearchRec;
reftime: TDateTime;
s: RawByteString;
begin
result := 0;
ref := IncludeTrailingPathDelimiter(Reference);
dst := IncludeTrailingPathDelimiter(Dest);
if DirectoryExists(ref) and (FindFirst(dst+FILES_ALL,faAnyFile,fdst)=0) then begin
repeat
if SearchRecValidFile(fdst) then begin
if ByContent then
reftime := FileAgeToDateTime(ref+fdst.Name) else
if FindFirst(ref+fdst.Name,faAnyFile,fref)=0 then begin
reftime := SearchRecToDateTime(fref);
if (fdst.Size=fref.Size) and (SearchRecToDateTime(fdst)=reftime) then
reftime := 0;
FindClose(fref);
end else
reftime := 0; // "continue" trigger unexpected warning on Delphi
if reftime=0 then
continue; // skip if no reference file to copy from
s := StringFromFile(ref+fdst.Name);
if (s='') or (ByContent and (length(s)=fdst.Size) and
(DefaultHasher(0,pointer(s),fdst.Size)=HashFile(dst+fdst.Name))) then
continue;
FileFromString(s,dst+fdst.Name,false,reftime);
inc(result);
if WriteFileNameToConsole then
{$I-} writeln('synched ',dst,fdst.name); {$I+}
end else if SubFolder and SearchRecValidFolder(fdst) then
inc(result,SynchFolders(ref+fdst.Name,dst+fdst.Name,SubFolder,ByContent,WriteFileNameToConsole));
until FindNext(fdst)<>0;
FindClose(fdst);
end;
end;
function EnsureDirectoryExists(const Directory: TFileName;
RaiseExceptionOnCreationFailure: boolean): TFileName;
begin
result := IncludeTrailingPathDelimiter(ExpandFileName(Directory));
if not DirectoryExists(result) then
if not CreateDir(result) then
if not RaiseExceptionOnCreationFailure then
result := '' else
raise ESynException.CreateUTF8('Impossible to create folder %',[result]);
end;
var
TemporaryFileNameRandom: integer;
function TemporaryFileName: TFileName;
var folder: TFileName;
begin // fast cross-platform implementation
folder := GetSystemPath(spTempFolder);
if TemporaryFileNameRandom=0 then
TemporaryFileNameRandom := Random32gsl;
repeat // thread-safe unique file name generation
FormatString('%%_%.tmp',[folder,ExeVersion.ProgramName,
CardinalToHexShort(InterlockedIncrement(TemporaryFileNameRandom))],string(result));
until not FileExists(result);
end;
function IsDirectoryWritable(const Directory: TFileName): boolean;
var fn: TFileName;
begin
fn := ExcludeTrailingPathDelimiter(Directory);
result := {$ifndef DELPHI5OROLDER}not FileIsReadOnly{$else}DirectoryExists{$endif}(fn);
if not result then
exit;
fn := FormatString('%%.%%',[fn,PathDelim,CardinalToHexShort(integer(GetCurrentThreadID)),
BinToBase64uriShort(@ExeVersion.Hash,SizeOf(ExeVersion.Hash))]);
result := FileFromString('tobedeleted',fn); // actually try to write something
DeleteFile(fn);
end;
{$ifdef DELPHI5OROLDER}
function DirectoryExists(const Directory: string): boolean;
var Code: Integer;
begin
Code := GetFileAttributes(pointer(Directory));
result := (Code<>-1) and (FILE_ATTRIBUTE_DIRECTORY and Code<>0);
end;
function SameFileName(const S1, S2: TFileName): Boolean;
begin
result := AnsiCompareFileName(S1,S2)=0;
end;
function GetEnvironmentVariable(const Name: string): string;
var Len: Integer;
Buffer: array[0..1023] of Char;
begin
Result := '';
Len := Windows.GetEnvironmentVariable(pointer(Name),@Buffer,SizeOf(Buffer));
if Len<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}
{$ifdef DELPHI6OROLDER}
procedure VarCastError;
begin
raise EVariantError.Create('Variant Type Cast Error');
end;
{$endif}
{$ifdef MSWINDOWS}
function FileSetDateFrom(const Dest: TFileName; SourceHandle: integer): boolean;
var FileTime: TFileTime;
D: THandle;
begin
D := FileOpen(Dest,fmOpenWrite);
if D<>THandle(-1) then begin
result := GetFileTime(SourceHandle,nil,nil,@FileTime) and
SetFileTime(D,nil,nil,@FileTime);
FileClose(D);
end else
result := false;
end;
{$else}
function FileSetDateFrom(const Dest: TFileName; SourceHandle: integer): boolean;
begin
result := FileSetDate(Dest,FileGetDate(SourceHandle))=0;
end;
{$endif}
{$IFDEF PUREPASCAL}
{$IFNDEF HASCODEPAGE}
function Pos(const substr, str: RawUTF8): Integer; overload;
begin // the RawByteString version is fast enough
Result := PosEx(substr,str,1);
end;
{$ENDIF}
{$ENDIF}
function FindObjectEntry(const Content, Name: RawUTF8): RawUTF8;
var L: integer;
begin
result := Trim(FindIniEntry(Content,'',Name+' ')); // 'Name = Value' format
if (result<>'') and (result[1]='''') then begin
L := length(result);
if result[L]='''' then
result := copy(result,2,L-2); // 'testDI6322.IAS' -> testDI6322.IAS
end;
end;
function FindObjectEntryWithoutExt(const Content, Name: RawUTF8): RawUTF8;
begin
result := RawUTF8(GetFileNameWithoutExt(
ExtractFileName(TFileName(FindObjectEntry(Content,Name)))));
end;
function Int64ScanExists(P: PInt64Array; Count: PtrInt; const Value: Int64): boolean;
begin
if P<>nil then begin
result := true;
Count := PtrInt(@P[Count-4]);
repeat
if PtrUInt(P)>PtrUInt(Count) then
break;
if (P^[0]=Value) or (P^[1]=Value) or (P^[2]=Value) or (P^[3]=Value) then
exit;
P := @P[4];
until false;
inc(Count,4*SizeOf(Value));
repeat
if PtrUInt(P)>=PtrUInt(Count) then
break;
if P^[0]=Value then
exit else
P := @P[1];
until false;
end;
result := false;
end;
function Int64Scan(P: PInt64Array; Count: PtrInt; const Value: Int64): PInt64;
begin
result := nil;
if P=nil then
exit;
Count := PtrInt(@P[Count-4]);
repeat
if PtrUInt(P)>PtrUInt(Count) then
break;
if P^[0]<>Value then
if P^[1]<>Value then
if P^[2]<>Value then
if P^[3]<>Value then begin
P := @P[4];
continue;
end else
result := @P[3] else
result := @P[2] else
result := @P[1] else
result := pointer(P);
exit;
until false;
inc(Count,4*SizeOf(Value));
result := pointer(P);
repeat
if PtrUInt(result)>=PtrUInt(Count) then
break;
if result^=Value then
exit else
inc(result);
until false;
result := nil;
end;
function AddInteger(var Values: TIntegerDynArray; Value: integer;
NoDuplicates: boolean): boolean;
var n: PtrInt;
begin
n := Length(Values);
if NoDuplicates and IntegerScanExists(pointer(Values),n,Value) then begin
result := false;
exit;
end;
SetLength(Values,n+1);
Values[n] := Value;
result := true
end;
procedure AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer;
Value: integer);
begin
if ValuesCount=length(Values) then
SetLength(Values,NextGrow(ValuesCount));
Values[ValuesCount] := Value;
inc(ValuesCount);
end;
function AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer;
Value: integer; NoDuplicates: boolean): boolean;
begin
if NoDuplicates and IntegerScanExists(pointer(Values),ValuesCount,Value) then begin
result := false;
exit;
end;
if ValuesCount=length(Values) then
SetLength(Values,NextGrow(ValuesCount));
Values[ValuesCount] := Value;
inc(ValuesCount);
result := true;
end;
function AddInteger(var Values: TIntegerDynArray; const Another: TIntegerDynArray): PtrInt;
var v,a: PtrInt;
begin
v := length(Values);
a := length(Another);
if a>0 then begin
SetLength(Values,v+a);
MoveFast(Another[0],Values[v],a*SizeOf(Integer));
end;
result := v+a;
end;
function AddWord(var Values: TWordDynArray; var ValuesCount: integer; Value: Word): PtrInt;
begin
result := ValuesCount;
if result=length(Values) then
SetLength(Values,NextGrow(result));
Values[result] := Value;
inc(ValuesCount);
end;
function AddInt64(var Values: TInt64DynArray; var ValuesCount: integer; Value: Int64): PtrInt;
begin
result := ValuesCount;
if result=length(Values) then
SetLength(Values,NextGrow(result));
Values[result] := Value;
inc(ValuesCount);
end;
function AddInt64(var Values: TInt64DynArray; Value: Int64): PtrInt;
begin
result := length(Values);
SetLength(Values,result+1);
Values[result] := Value;
end;
function AddInt64(var Values: TInt64DynArray; const Another: TInt64DynArray): PtrInt;
var v,a: PtrInt;
begin
v := length(Values);
a := length(Another);
if a>0 then begin
SetLength(Values,v+a);
MoveFast(Another[0],Values[v],a*SizeOf(Int64));
end;
result := v+a;
end;
procedure AddInt64Sorted(var Values: TInt64DynArray; Value: Int64);
var last: integer;
begin
last := high(Values);
if FastFindInt64Sorted(pointer(Values),last,Value)<0 then begin
inc(last);
SetLength(Values,last+1);
Values[last] := Value;
QuickSortInt64(pointer(Values),0,last);
end;
end;
function AddInt64Once(var Values: TInt64DynArray; Value: Int64): PtrInt;
begin
result := Int64ScanIndex(pointer(Values),length(Values),Value);
if result<0 then
result := AddInt64(Values,Value);
end;
procedure DynArrayMakeUnique(Values: PPointer; TypeInfo: pointer);
var da: TDynArray;
n: PtrInt;
begin // caller ensured that Values<>nil, Values^<>nil and RefCnt>1
da.Init(TypeInfo,Values^);
n := PDALen(PPtrUInt(Values)^-_DALEN)^{$ifdef FPC}+1{$endif};
da.InternalSetLength(n,n); // make copy
end;
procedure DeleteWord(var Values: TWordDynArray; Index: PtrInt);
var n: PtrInt;
begin
n := Length(Values);
if PtrUInt(Index)>=PtrUInt(n) then
exit; // wrong Index
dec(n);
if n>Index then begin
if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then
DynArrayMakeUnique(@Values,TypeInfo(TWordDynArray));
MoveFast(Values[Index+1],Values[Index],(n-Index)*SizeOf(Word));
end;
SetLength(Values,n);
end;
procedure DeleteInteger(var Values: TIntegerDynArray; Index: PtrInt);
var n: PtrInt;
begin
n := Length(Values);
if PtrUInt(Index)>=PtrUInt(n) then
exit; // wrong Index
dec(n);
if n>Index then begin
if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then
DynArrayMakeUnique(@Values,TypeInfo(TIntegerDynArray));
MoveFast(Values[Index+1],Values[Index],(n-Index)*SizeOf(Integer));
end;
SetLength(Values,n);
end;
procedure DeleteInteger(var Values: TIntegerDynArray; var ValuesCount: Integer; Index: PtrInt);
var n: PtrInt;
begin
n := ValuesCount;
if PtrUInt(Index)>=PtrUInt(n) then
exit; // wrong Index
dec(n,Index+1);
if n>0 then begin
if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then
DynArrayMakeUnique(@Values,TypeInfo(TIntegerDynArray));
MoveFast(Values[Index+1],Values[Index],n*SizeOf(Integer));
end;
dec(ValuesCount);
end;
procedure DeleteInt64(var Values: TInt64DynArray; Index: PtrInt);
var n: PtrInt;
begin
n := Length(Values);
if PtrUInt(Index)>=PtrUInt(n) then
exit; // wrong Index
dec(n);
if n>Index then begin
if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then
DynArrayMakeUnique(@Values,TypeInfo(TInt64DynArray));
MoveFast(Values[Index+1],Values[Index],(n-Index)*SizeOf(Int64));
end;
SetLength(Values,n);
end;
procedure DeleteInt64(var Values: TInt64DynArray; var ValuesCount: Integer; Index: PtrInt);
var n: PtrInt;
begin
n := ValuesCount;
if PtrUInt(Index)>=PtrUInt(n) then
exit; // wrong Index
dec(n,Index+1);
if n>0 then begin
if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then
DynArrayMakeUnique(@Values,TypeInfo(TInt64DynArray));
MoveFast(Values[Index+1],Values[Index],n*SizeOf(Int64));
end;
dec(ValuesCount);
end;
procedure ExcludeInteger(var Values, Excluded: TIntegerDynArray; ExcludedSortSize: integer);
var i,v,x,n: PtrInt;
begin
if (Values=nil) or (Excluded=nil) then
exit; // nothing to exclude
if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then
DynArrayMakeUnique(@Values,TypeInfo(TIntegerDynArray));
if PDACnt(PtrUInt(Excluded)-_DAREFCNT)^>1 then
DynArrayMakeUnique(@Excluded,TypeInfo(TIntegerDynArray));
v := length(Values);
n := 0;
x := Length(Excluded);
if (x>ExcludedSortSize) or (v>ExcludedSortSize) then begin // sort if worth it
dec(x);
QuickSortInteger(pointer(Excluded),0,x);
for i := 0 to v-1 do
if FastFindIntegerSorted(pointer(Excluded),x,Values[i])<0 then begin
if n<>i then
Values[n] := Values[i];
inc(n);
end;
end else
for i := 0 to v-1 do
if not IntegerScanExists(pointer(Excluded),x,Values[i]) then begin
if n<>i then
Values[n] := Values[i];
inc(n);
end;
if n<>v then
SetLength(Values,n);
end;
procedure IncludeInteger(var Values, Included: TIntegerDynArray;
IncludedSortSize: Integer);
var i,v,x,n: PtrInt;
begin
if (Values=nil) or (Included=nil) then begin
Values := nil;
exit;
end;
if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then
DynArrayMakeUnique(@Values,TypeInfo(TIntegerDynArray));
if PDACnt(PtrUInt(Included)-_DAREFCNT)^>1 then
DynArrayMakeUnique(@Included,TypeInfo(TIntegerDynArray));
v := length(Values);
n := 0;
x := Length(Included);
if (x>IncludedSortSize) or (v>IncludedSortSize) then begin // sort if worth it
dec(x);
QuickSortInteger(pointer(Included),0,x);
for i := 0 to v-1 do
if FastFindIntegerSorted(pointer(Included),x,Values[i])>=0 then begin
if n<>i then
Values[n] := Values[i];
inc(n);
end;
end else
for i := 0 to v-1 do
if IntegerScanExists(pointer(Included),x,Values[i]) then begin
if n<>i then
Values[n] := Values[i];
inc(n);
end;
if n<>v then
SetLength(Values,n);
end;
procedure ExcludeInt64(var Values, Excluded: TInt64DynArray; ExcludedSortSize: Integer);
var i,v,x,n: PtrInt;
begin
if (Values=nil) or (Excluded=nil) then
exit; // nothing to exclude
v := length(Values);
n := 0;
x := Length(Excluded);
if (x>ExcludedSortSize) or (v>ExcludedSortSize) then begin // sort if worth it
dec(x);
QuickSortInt64(pointer(Excluded),0,x);
for i := 0 to v-1 do
if FastFindInt64Sorted(pointer(Excluded),x,Values[i])<0 then begin
if n<>i then
Values[n] := Values[i];
inc(n);
end;
end else
for i := 0 to v-1 do
if not Int64ScanExists(pointer(Excluded),x,Values[i]) then begin
if n<>i then
Values[n] := Values[i];
inc(n);
end;
if n<>v then
SetLength(Values,n);
end;
procedure IncludeInt64(var Values, Included: TInt64DynArray;
IncludedSortSize: integer);
var i,v,x,n: PtrInt;
begin
if (Values=nil) or (Included=nil) then begin
Values := nil;
exit;
end;
v := length(Values);
n := 0;
x := Length(Included);
if (x>IncludedSortSize) or (v>IncludedSortSize) then begin // sort if worth it
dec(x);
QuickSortInt64(pointer(Included),0,x);
for i := 0 to v-1 do
if FastFindInt64Sorted(pointer(Included),x,Values[i])>=0 then begin
if n<>i then
Values[n] := Values[i];
inc(n);
end;
end else
for i := 0 to v-1 do
if Int64ScanExists(pointer(Included),x,Values[i]) then begin
if n<>i then
Values[n] := Values[i];
inc(n);
end;
if n<>v then
SetLength(Values,n);
end;
procedure DeduplicateInteger(var Values: TIntegerDynArray);
begin
DeduplicateInteger(Values, length(Values));
end;
function DeduplicateIntegerSorted(val: PIntegerArray; last: PtrInt): PtrInt;
var i: PtrInt;
begin // sub-function for better code generation
i := 0;
repeat // here last>0 so i<last
if val[i]=val[i+1] then
break;
inc(i);
if i<>last then
continue;
result := i;
exit;
until false;
result := i;
inc(i);
if i<>last then begin
repeat
if val[i]<>val[i+1] then begin
val[result] := val[i];
inc(result);
end;
inc(i);
until i=last;
val[result] := val[i];
end;
end;
function DeduplicateInteger(var Values: TIntegerDynArray; Count: integer): integer;
begin
result := Count;
dec(Count);
if Count>0 then begin
QuickSortInteger(pointer(Values),0,Count);
result := DeduplicateIntegerSorted(pointer(Values),Count)+1;
end;
if result<>length(Values) then
SetLength(Values,result);
end;
procedure DeduplicateInt64(var Values: TInt64DynArray);
begin
DeduplicateInt64(Values, length(Values));
end;
function DeduplicateInt64Sorted(val: PInt64Array; last: PtrInt): PtrInt;
var i: PtrInt;
begin // sub-function for better code generation
i := 0;
repeat // here last>0 so i<last
if val[i]=val[i+1] then
break;
inc(i);
if i<>last then
continue;
result := i;
exit;
until false;
result := i;
inc(i);
if i<>last then begin
repeat
if val[i]<>val[i+1] then begin
val[result] := val[i];
inc(result);
end;
inc(i);
until i=last;
val[result] := val[i];
end;
end;
function DeduplicateInt64(var Values: TInt64DynArray; Count: integer): integer;
begin
result := Count;
dec(Count);
if Count>0 then begin
QuickSortInt64(pointer(Values),0,Count);
result := DeduplicateInt64Sorted(pointer(Values),Count)+1;
end;
if result<>length(Values) then
SetLength(Values,result);
end;
procedure CopyInteger(const Source: TIntegerDynArray; out Dest: TIntegerDynArray);
var n: integer;
begin
n := length(Source);
SetLength(Dest,n);
MoveFast(Source[0],Dest[0],n*SizeOf(Integer));
end;
procedure CopyInt64(const Source: TInt64DynArray; out Dest: TInt64DynArray);
var n: integer;
begin
n := length(Source);
SetLength(Dest,n);
MoveFast(Source[0],Dest[0],n*SizeOf(Int64));
end;
function MaxInteger(const Values: TIntegerDynArray; ValuesCount: PtrInt; MaxStart: integer): Integer;
var i: PtrInt;
v: integer;
begin
result := MaxStart;
for i := 0 to ValuesCount-1 do begin
v := Values[i];
if v>result then
result := v; // branchless opcode on FPC
end;
end;
function SumInteger(const Values: TIntegerDynArray; ValuesCount: PtrInt): Integer;
var i: PtrInt;
begin
result := 0;
for i := 0 to ValuesCount-1 do
inc(result,Values[i]);
end;
procedure Reverse(const Values: TIntegerDynArray; ValuesCount: PtrInt;
Reversed: PIntegerArray);
var i: PtrInt;
begin
i := 0;
if ValuesCount>=4 then begin
dec(ValuesCount,4);
while 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: integer; Count: PtrUInt);
var i: PtrUInt;
begin
if Count>0 then
if StartValue=0 then
for i := 0 to Count-1 do
Values[i] := i else
for i := 0 to Count-1 do begin
Values[i] := StartValue;
inc(StartValue);
end;
end;
procedure Int64ToUInt32(Values64: PInt64Array; Values32: PCardinalArray; Count: PtrInt);
var i: PtrInt;
begin
for i := 0 to Count-1 do
Values32[i] := Values64[i];
end;
procedure CSVToIntegerDynArray(CSV: PUTF8Char; var Result: TIntegerDynArray; Sep: AnsiChar);
begin
while CSV<>nil do begin
SetLength(Result,length(Result)+1);
Result[high(Result)] := GetNextItemInteger(CSV,Sep);
end;
end;
procedure CSVToInt64DynArray(CSV: PUTF8Char; var Result: TInt64DynArray; Sep: AnsiChar);
begin
while CSV<>nil do begin
SetLength(Result,length(Result)+1);
Result[high(Result)] := GetNextItemInt64(CSV,Sep);
end;
end;
function CSVToInt64DynArray(CSV: PUTF8Char; Sep: AnsiChar): TInt64DynArray;
begin
Finalize(result);
while CSV<>nil do begin
SetLength(Result,length(Result)+1);
Result[high(Result)] := GetNextItemInt64(CSV,Sep);
end;
end;
function IntegerDynArrayToCSV(Values: PIntegerArray; ValuesCount: integer;
const Prefix, Suffix: RawUTF8; InlinedValue: boolean): RawUTF8;
type
TInts16 = packed array[word] of string[15]; // shortstring are faster (no heap allocation)
var i, L, Len: PtrInt;
tmp: array[0..15] of AnsiChar;
ints: ^TInts16;
P: PAnsiChar;
tmpbuf: TSynTempBuffer;
begin
result := '';
if ValuesCount=0 then
exit;
if InlinedValue then
Len := 4*ValuesCount else
Len := 0;
tmpbuf.Init(ValuesCount*SizeOf(ints[0])+Len); // faster than a dynamic array
try
ints := tmpbuf.buf;
// compute whole result length at once
dec(ValuesCount);
inc(Len,length(Prefix)+length(Suffix));
tmp[15] := ',';
for i := 0 to ValuesCount do begin
P := StrInt32(@tmp[15],Values[i]);
L := @tmp[15]-P;
if i<ValuesCount then
inc(L); // append tmp[15]=','
inc(Len,L);
SetString(ints[i],P,L);
end;
// create result
FastSetString(result,nil,Len);
P := pointer(result);
if Prefix<>'' then begin
L := length(Prefix);
MoveSmall(pointer(Prefix),P,L);
inc(P,L);
end;
for i := 0 to ValuesCount do begin
if InlinedValue then begin
PWord(P)^ := ord(':')+ord('(')shl 8;
inc(P,2);
end;
L := ord(ints[i][0]);
MoveSmall(@ints[i][1],P,L);
inc(P,L);
if InlinedValue then begin
PWord(P)^ := ord(')')+ord(':')shl 8;
inc(P,2);
end;
end;
if Suffix<>'' then
MoveSmall(pointer(Suffix),P,length(Suffix));
finally
tmpbuf.Done;
end;
end;
function Int64DynArrayToCSV(Values: PInt64Array; ValuesCount: integer;
const Prefix, Suffix: RawUTF8; InlinedValue: boolean): RawUTF8;
type
TInt = packed record
Len: byte;
Val: array[0..19] of AnsiChar; // Int64: 19 digits, then - sign
end;
var i, L, Len: PtrInt;
int: ^TInt;
P: PAnsiChar;
tmp: TSynTempBuffer;
begin
result := '';
if ValuesCount=0 then
exit;
if InlinedValue then
Len := 4*ValuesCount else
Len := 0;
int := tmp.Init(ValuesCount*SizeOf(TInt)+Len); // faster than a dynamic array
try
// compute whole result length at once
dec(ValuesCount);
inc(Len,length(Prefix)+length(Suffix));
for i := 0 to ValuesCount do begin
P := StrInt64(PAnsiChar(int)+21,Values[i]);
L := PAnsiChar(int)+21-P;
int^.Len := L;
if i<ValuesCount then
inc(L); // for ,
inc(Len,L);
inc(int);
end;
// create result
FastSetString(result,nil,Len);
P := pointer(result);
if Prefix<>'' then begin
L := length(Prefix);
MoveSmall(pointer(Prefix),P,L);
inc(P,L);
end;
int := tmp.buf;
repeat
if InlinedValue then begin
PWord(P)^ := ord(':')+ord('(')shl 8;
inc(P,2);
end;
L := int^.Len;
MoveSmall(PAnsiChar(int)+21-L,P,L);
inc(P,L);
if InlinedValue then begin
PWord(P)^ := ord(')')+ord(':')shl 8;
inc(P,2);
end;
if ValuesCount=0 then
break;
inc(int);
P^ := ',';
inc(P);
dec(ValuesCount);
until false;
if Suffix<>'' then
MoveSmall(pointer(Suffix),P,length(Suffix));
finally
tmp.Done;
end;
end;
function IntegerDynArrayToCSV(const Values: TIntegerDynArray;
const Prefix, Suffix: RawUTF8; InlinedValue: boolean): RawUTF8;
begin
result := IntegerDynArrayToCSV(pointer(Values),length(Values),Prefix,Suffix,InlinedValue);
end;
function Int64DynArrayToCSV(const Values: TInt64DynArray;
const Prefix: RawUTF8; const Suffix: RawUTF8; InlinedValue: boolean): RawUTF8;
begin
result := Int64DynArrayToCSV(pointer(Values),length(Values),Prefix,Suffix,InlinedValue);
end;
function Int64ScanIndex(P: PInt64Array; Count: PtrInt; const Value: Int64): PtrInt;
begin
result := 0;
dec(Count,8);
if P<>nil then begin
repeat
if result>Count then
break;
if P^[result]<>Value then
if P^[result+1]<>Value then
if P^[result+2]<>Value then
if P^[result+3]<>Value then
if P^[result+4]<>Value then
if P^[result+5]<>Value then
if P^[result+6]<>Value then
if P^[result+7]<>Value then begin
inc(result,8);
continue;
end else
inc(result,7) else
inc(result,6) else
inc(result,5) else
inc(result,4) else
inc(result,3) else
inc(result,2) else
inc(result);
exit;
until false;
inc(Count,8);
repeat
if result>=Count then
break;
if P^[result]=Value then
exit else
inc(result);
until false;
end;
result := -1;
end;
function QWordScanIndex(P: PQWordArray; Count: PtrInt; const Value: QWord): PtrInt;
begin
result := Int64ScanIndex(pointer(P),Count,Value); // this is the very same code
end;
function PtrUIntScan(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): pointer;
{$ifdef HASINLINE}
begin
result := {$ifdef CPU64}Int64Scan{$else}IntegerScan{$endif}(pointer(P),Count,Value);
end;
{$else}
asm
jmp IntegerScan
end;
{$endif HASINLINE}
function PtrUIntScanExists(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): boolean;
{$ifdef HASINLINE}
begin
result := {$ifdef CPU64}Int64ScanExists{$else}IntegerScanExists{$endif}(pointer(P),Count,Value);
end;
{$else}
asm
jmp IntegerScanExists;
end;
{$endif HASINLINE}
function PtrUIntScanIndex(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): PtrInt;
{$ifdef HASINLINE}
begin
result := {$ifdef CPU64}Int64ScanIndex{$else}IntegerScanIndex{$endif}(pointer(P),Count,Value);
end;
{$else}
asm // identical to IntegerScanIndex() asm stub
push eax
call IntegerScan
pop edx
test eax, eax
jnz @e
dec eax // returns -1
ret
@e: sub eax, edx
shr eax, 2
end;
{$endif HASINLINE}
function ByteScanIndex(P: PByteArray; Count: PtrInt; Value: Byte): PtrInt;
begin
{$ifdef FPC}
result := IndexByte(P^,Count,Value); // will use fast FPC SSE version
{$else}
result := 0;
if P<>nil then
repeat
if result>=Count then
break;
if P^[result]=Value then
exit else
inc(result);
until false;
result := -1;
{$endif FPC}
end;
function WordScanIndex(P: PWordArray; Count: PtrInt; Value: word): PtrInt;
begin
{$ifdef FPC}
result := IndexWord(P^,Count,Value); // will use fast FPC SSE version
{$else}
result := 0;
if P<>nil then
repeat
if result>=Count then
break;
if P^[result]=Value then
exit else
inc(result);
until false;
result := -1;
{$endif FPC}
end;
function AnyScanIndex(P,Elem: pointer; Count,ElemSize: PtrInt): PtrInt;
begin
case ElemSize of
// optimized versions for arrays of byte,word,integer,Int64,Currency,Double
1: result := ByteScanIndex(P,Count,PByte(Elem)^);
2: result := WordScanIndex(P,Count,PWord(Elem)^);
4: result := IntegerScanIndex(P,Count,PInteger(Elem)^);
8: result := Int64ScanIndex(P,Count,PInt64(Elem)^);
// small ElemSize version (<SizeOf(PtrInt))
3,5..7: begin
for result := 0 to Count-1 do
if CompareMemSmall(P,Elem,ElemSize) then
exit else
inc(PByte(P),ElemSize);
result := -1;
end;
else begin // generic binary comparison (fast with inlined CompareMemFixed)
for result := 0 to Count-1 do
if (PInt64(P)^=PInt64(Elem)^) and
CompareMemSmall(PAnsiChar(P)+8,PAnsiChar(Elem)+8,ElemSize-8) then
exit else
inc(PByte(P),ElemSize);
result := -1;
end;
end;
end;
function AnyScanExists(P,Elem: pointer; Count,ElemSize: PtrInt): boolean;
begin
case ElemSize of
// optimized versions for arrays of byte,word,integer,Int64,Currency,Double
1: result := ByteScanIndex(P,Count,PInteger(Elem)^)>=0;
2: result := WordScanIndex(P,Count,PInteger(Elem)^)>=0;
4: result := IntegerScanExists(P,Count,PInteger(Elem)^);
8: result := Int64ScanExists(P,Count,PInt64(Elem)^);
// small ElemSize version (<SizeOf(PtrInt))
3,5..7: begin
result := true;
if Count>0 then
repeat
if CompareMemSmall(P,Elem,ElemSize) then
exit;
inc(PByte(P),ElemSize);
dec(Count);
until Count=0;
result := false;
end;
else begin // generic binary comparison (fast with leading 64-bit comparison)
result := true;
if Count>0 then
repeat
if (PInt64(P)^=PInt64(Elem)^) and
CompareMemSmall(PAnsiChar(P)+8,PAnsiChar(Elem)+8,ElemSize-8) then
exit;
inc(PByte(P),ElemSize);
dec(Count);
until Count=0;
result := false;
end;
end;
end;
procedure QuickSortInteger(ID: PIntegerArray; L,R: PtrInt);
var I, J, P: PtrInt;
tmp: integer;
begin
if L<R then
repeat
I := L; J := R;
P := (L + R) shr 1;
repeat
tmp := ID^[P];
if ID[I]<tmp then repeat inc(I) until ID[I]>=tmp;
if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp;
if I <= J then begin
tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp;
if P = I then P := J else if P = J then P := I;
inc(I); dec(J);
end;
until I > J;
if J - L < R - I then begin // use recursion only for smaller range
if L < J then
QuickSortInteger(ID, L, J);
L := I;
end else begin
if I < R then
QuickSortInteger(ID, I, R);
R := J;
end;
until L >= R;
end;
procedure QuickSortInteger(var ID: TIntegerDynArray);
begin
QuickSortInteger(pointer(ID),0,high(ID));
end;
procedure QuickSortInteger(ID,CoValues: PIntegerArray; L,R: PtrInt);
var I, J, P: PtrInt;
tmp: integer;
begin
if L<R then
repeat
I := L; J := R;
P := (L + R) shr 1;
repeat
tmp := ID[P];
if ID[I]<tmp then repeat inc(I) until ID[I]>=tmp;
if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp;
if I <= J then begin
tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp;
tmp := CoValues[J]; CoValues[J] := CoValues[I]; CoValues[I] := tmp;
if P = I then P := J else if P = J then P := I;
inc(I); dec(J);
end;
until I > J;
if J - L < R - I then begin // use recursion only for smaller range
if L < J then
QuickSortInteger(ID, CoValues, L, J);
L := I;
end else begin
if I < R then
QuickSortInteger(ID, CoValues, I, R);
R := J;
end;
until L >= R;
end;
procedure QuickSortWord(ID: PWordArray; L, R: PtrInt);
var I, J, P: PtrInt;
tmp: word;
begin
if L<R then
repeat
I := L; J := R;
P := (L + R) shr 1;
repeat
tmp := ID[P];
if ID[I]<tmp then repeat inc(I) until ID[I]>=tmp;
if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp;
if I <= J then begin
tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp;
if P = I then P := J else if P = J then P := I;
inc(I); dec(J);
end;
until I > J;
if J - L < R - I then begin // use recursion only for smaller range
if L < J then
QuickSortWord(ID, L, J);
L := I;
end else begin
if I < R then
QuickSortWord(ID, I, R);
R := J;
end;
until L >= R;
end;
procedure QuickSortInt64(ID: PInt64Array; L, R: PtrInt);
var I, J, P: PtrInt;
tmp: Int64;
begin
if L<R then
repeat
I := L; J := R;
P := (L + R) shr 1;
repeat
{$ifdef CPU64}
tmp := ID^[P];
if ID[I]<tmp then repeat inc(I) until ID[I]>=tmp;
if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp;
{$else}
while ID[I]<ID[P] do inc(I);
while ID[J]>ID[P] do dec(J);
{$endif}
if I <= J then begin
tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp;
if P = I then P := J else if P = J then P := I;
inc(I); dec(J);
end;
until I > J;
if J - L < R - I then begin // use recursion only for smaller range
if L < J then
QuickSortInt64(ID, L, J);
L := I;
end else begin
if I < R then
QuickSortInt64(ID, I, R);
R := J;
end;
until L >= R;
end;
procedure QuickSortQWord(ID: PQWordArray; L, R: PtrInt);
var I, J, P: PtrInt;
tmp: QWord;
begin
if L<R then
repeat
I := L; J := R;
P := (L + R) shr 1;
repeat
{$ifdef CPUX86} // circumvent QWord comparison slowness (and bug)
while SortDynArrayQWord(ID[I],ID[P])<0 do inc(I);
while SortDynArrayQWord(ID[J],ID[P])>0 do dec(J);
{$else}
tmp := ID[P];
if ID[I]<tmp then repeat inc(I) until ID[I]>=tmp;
if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp;
{$endif}
if I <= J then begin
tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp;
if P = I then P := J else if P = J then P := I;
inc(I); dec(J);
end;
until I > J;
if J - L < R - I then begin // use recursion only for smaller range
if L < J then
QuickSortQWord(ID, L, J);
L := I;
end else begin
if I < R then
QuickSortQWord(ID, I, R);
R := J;
end;
until L >= R;
end;
procedure QuickSortInt64(ID,CoValues: PInt64Array; L, R: PtrInt);
var I, J, P: PtrInt;
tmp: Int64;
begin
if L<R then
repeat
I := L; J := R;
P := (L + R) shr 1;
repeat
{$ifdef CPU64}
tmp := ID^[P];
if ID[I]<tmp then repeat inc(I) until ID[I]>=tmp;
if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp;
{$else}
while ID[I]<ID[P] do inc(I);
while ID[J]>ID[P] do dec(J);
{$endif}
if I <= J then begin
tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp;
tmp := CoValues[J]; CoValues[J] := CoValues[I]; CoValues[I] := tmp;
if P = I then P := J else if P = J then P := I;
inc(I); dec(J);
end;
until I > J;
if J - L < R - I then begin // use recursion only for smaller range
if L < J then
QuickSortInt64(ID, CoValues, L, J);
L := I;
end else begin
if I < R then
QuickSortInt64(ID, CoValues, I, R);
R := J;
end;
until L >= R;
end;
procedure QuickSortPtrInt(P: PPtrIntArray; L, R: PtrInt);
begin
{$ifdef CPU64}
QuickSortInt64(PInt64Array(P),L,R);
{$else}
QuickSortInteger(PIntegerArray(P),L,R);
{$endif}
end;
function FastFindPtrIntSorted(P: PPtrIntArray; R: PtrInt; Value: PtrInt): PtrInt;
begin
{$ifdef CPU64}
result := FastFindInt64Sorted(PInt64Array(P),R,Value);
{$else}
result := FastFindIntegerSorted(PIntegerArray(P),R,Value);
{$endif}
end;
procedure QuickSortPointer(P: PPointerArray; L, R: PtrInt);
begin
{$ifdef CPU64}
QuickSortInt64(PInt64Array(P),L,R);
{$else}
QuickSortInteger(PIntegerArray(P),L,R);
{$endif}
end;
function FastFindPointerSorted(P: PPointerArray; R: PtrInt; Value: pointer): PtrInt;
begin
{$ifdef CPU64}
result := FastFindInt64Sorted(PInt64Array(P),R,Int64(Value));
{$else}
result := FastFindIntegerSorted(PIntegerArray(P),R,integer(Value));
{$endif}
end;
procedure NotifySortedIntegerChanges(old, new: PIntegerArray; oldn, newn: PtrInt;
const added, deleted: TOnNotifySortedIntegerChange; const sender);
var o, n: PtrInt;
begin
o := 0;
n := 0;
repeat
while (n<newn) and (o<oldn) and (old[o]=new[n]) do begin
inc(o);
inc(n);
end;
while (o<oldn) and ((n>=newn) or (old[o]<new[n])) do begin
if Assigned(deleted) then
deleted(sender,old[o]);
inc(o);
end;
while (n<newn) and ((o>=oldn) or (new[n]<old[o])) do begin
if Assigned(added) then
added(sender,new[n]);
inc(n);
end;
until (o>=oldn) and (n>=newn);
end;
procedure CopyAndSortInteger(Values: PIntegerArray; ValuesCount: integer;
var Dest: TIntegerDynArray);
begin
if ValuesCount>length(Dest) then
SetLength(Dest,ValuesCount);
MoveFast(Values^[0],Dest[0],ValuesCount*SizeOf(Integer));
QuickSortInteger(pointer(Dest),0,ValuesCount-1);
end;
procedure CopyAndSortInt64(Values: PInt64Array; ValuesCount: integer;
var Dest: TInt64DynArray);
begin
if ValuesCount>length(Dest) then
SetLength(Dest,ValuesCount);
MoveFast(Values^[0],Dest[0],ValuesCount*SizeOf(Int64));
QuickSortInt64(pointer(Dest),0,ValuesCount-1);
end;
function FastFindIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt;
{$ifdef CPUX64} // P=rcx/rdi R=rdx/rsi Value=r8d/edx
{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif}
xor r9, r9 // r9=L rax=result
test R, R
jl @ko
lea rax, [r9 + R]
{$ifdef FPC} align 8 {$else} .align 8 {$endif}
@s: shr rax, 1
lea r10, qword ptr[rax - 1] // efficient branchless binary search
lea r11, qword ptr[rax + 1]
cmp Value, dword ptr[P + rax * 4]
je @ok
cmovl R, r10
cmovg r9, r11
lea rax, [r9 + R]
cmp r9, R
jle @s
@ko: or rax, -1
@ok:
end;
{$else}
var L: PtrInt;
cmp: integer;
begin
L := 0;
if 0<=R then
repeat
result := (L + R) shr 1;
cmp := P^[result]-Value;
if cmp=0 then
exit;
if cmp<0 then begin
L := result+1;
if L<=R then
continue;
break;
end;
R := result-1;
if L<=R then
continue;
break;
until false;
result := -1
end;
{$endif CPUX64}
function FastFindIntegerSorted(const Values: TIntegerDynArray; Value: integer): PtrInt;
begin
result := FastFindIntegerSorted(pointer(Values),length(Values)-1,Value);
end;
function FastFindInt64Sorted(P: PInt64Array; R: PtrInt; const Value: Int64): PtrInt;
{$ifdef CPUX64} // P=rcx/rdi R=rdx/rsi Value=r8d/edx
{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif}
xor r9, r9 // r9=L rax=result
test R, R
jl @ko
lea rax, [r9 + R]
{$ifdef FPC} align 8 {$else} .align 8 {$endif}
@s: shr rax, 1
lea r10, qword ptr[rax - 1] // efficient branchless binary search
lea r11, qword ptr[rax + 1]
cmp Value, qword ptr[P + rax * 8]
je @ok
cmovl R, r10
cmovg r9, r11
lea rax, [r9 + R]
cmp r9, R
jle @s
@ko: or rax, -1
@ok:
end;
{$else}
var L: PtrInt;
{$ifdef CPUX86}
cmp: Integer;
{$endif}
begin
L := 0;
if 0<=R then
repeat
result := (L + R) shr 1;
{$ifndef CPUX86}
if P^[result]=Value then
exit else
if P^[result]<Value then begin
L := result+1;
if L<=R then
continue;
break;
end;
{$else} // circumvent Int64 comparison slowness
cmp := {$ifdef HASINLINE}CompareInt64{$else}SortDynArrayInt64{$endif}(P^[result],Value);
if cmp=0 then
exit else
if cmp<0 then begin
L := result+1;
if L<=R then
continue;
break;
end;
{$endif}
R := result-1;
if L<=R then
continue;
break;
until false;
result := -1
end;
{$endif CPUX64}
function FastFindQWordSorted(P: PQWordArray; R: PtrInt; const Value: QWord): PtrInt;
var L: PtrInt;
{$ifdef CPUX86}
cmp: Integer;
{$endif}
begin
L := 0;
if 0<=R then
repeat
result := (L + R) shr 1;
{$ifndef CPUX86}
if P^[result]=Value then
exit else
if P^[result]<Value then begin
L := result+1;
if L<=R then
continue;
break;
end;
{$else} // circumvent QWord comparison slowness (and bug)
cmp := SortDynArrayQWord(P^[result],Value);
if cmp=0 then
exit else
if cmp<0 then begin
L := result+1;
if L<=R then
continue;
break;
end;
{$endif}
R := result-1;
if L<=R then
continue;
break;
until false;
result := -1
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): PtrInt;
begin
result := FastLocateIntegerSorted(pointer(Values),ValuesCount-1,Value);
if result>=0 then // if Value exists -> fails
result := InsertInteger(Values,ValuesCount,Value,result,CoValues);
end;
function AddSortedInteger(var Values: TIntegerDynArray;
Value: integer; CoValues: PIntegerDynArray): PtrInt;
var ValuesCount: integer;
begin
ValuesCount := length(Values);
result := FastLocateIntegerSorted(pointer(Values),ValuesCount-1,Value);
if result>=0 then begin // if Value exists -> fails
SetLength(Values,ValuesCount+1); // manual size increase
result := InsertInteger(Values,ValuesCount,Value,result,CoValues);
end;
end;
function TSortedIntegerArray.Add(aValue: Integer): PtrInt;
begin
result := Count; // optimistic check of perfectly increasing aValue
if (result>0) and (aValue<=Values[result-1]) then
result := FastLocateIntegerSorted(pointer(Values),result-1,aValue);
if result<0 then // aValue already exists in Values[] -> fails
exit;
if Count=length(Values) then
SetLength(Values,NextGrow(Count));
if result<Count then
MoveFast(Values[result],Values[result+1],(Count-result)*SizeOf(Integer)) else
result := Count;
Values[result] := aValue;
inc(Count);
end;
function TSortedIntegerArray.IndexOf(aValue: Integer): PtrInt;
begin
result := FastFindIntegerSorted(pointer(Values),Count-1,aValue);
end;
function InsertInteger(var Values: TIntegerDynArray; var ValuesCount: integer;
Value: Integer; Index: PtrInt; CoValues: PIntegerDynArray): PtrInt;
var n: PtrInt;
begin
result := Index;
n := Length(Values);
if ValuesCount=n then begin
n := NextGrow(n);
SetLength(Values,n);
if CoValues<>nil then
SetLength(CoValues^,n);
end;
n := ValuesCount;
if PtrUInt(result)<PtrUInt(n) then begin
n := (n-result)*SizeOf(Integer);
MoveFast(Values[result],Values[result+1],n);
if CoValues<>nil then
MoveFast(CoValues^[result],CoValues^[result+1],n);
end else
result := n;
Values[result] := Value;
inc(ValuesCount);
end;
function TIntegerDynArrayFrom(const Values: array of integer): TIntegerDynArray;
var i: PtrInt;
begin
Finalize(result);
SetLength(result,length(Values));
for i := 0 to high(Values) do
result[i] := Values[i];
end;
function TIntegerDynArrayFrom64(const Values: TInt64DynArray;
raiseExceptionOnOverflow: boolean): TIntegerDynArray;
var i: PtrInt;
const MinInt = -MaxInt-1;
begin
Finalize(result);
SetLength(result,length(Values));
for i := 0 to length(Values)-1 do
if Values[i]>MaxInt then
if raiseExceptionOnOverflow then
raise 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: PtrInt;
begin
Finalize(result);
SetLength(result,length(Values));
for i := 0 to length(Values)-1 do
result[i] := Values[i];
end;
function TQWordDynArrayFrom(const Values: TCardinalDynArray): TQWordDynArray;
var i: PtrInt;
begin
Finalize(result);
SetLength(result,length(Values));
for i := 0 to length(Values)-1 do
result[i] := Values[i];
end;
function FromI32(const Values: array of integer): TIntegerDynArray;
var i: PtrInt;
begin
Finalize(result);
SetLength(result,length(Values));
for i := 0 to high(Values) do
result[i] := Values[i];
end;
function FromU32(const Values: array of cardinal): TCardinalDynArray;
var i: PtrInt;
begin
Finalize(result);
SetLength(result,length(Values));
for i := 0 to high(Values) do
result[i] := Values[i];
end;
function FromI64(const Values: array of Int64): TInt64DynArray;
var i: PtrInt;
begin
Finalize(result);
SetLength(result,length(Values));
for i := 0 to high(Values) do
result[i] := Values[i];
end;
function FromU64(const Values: array of QWord): TQWordDynArray;
var i: PtrInt;
begin
Finalize(result);
SetLength(result,length(Values));
for i := 0 to high(Values) do
result[i] := Values[i];
end;
function GetInteger(P: PUTF8Char): PtrInt;
var c: byte;
minus: boolean;
begin
result := 0;
if P=nil then
exit;
c := byte(P^);
repeat
if c=0 then
exit;
if c>ord(' ') then
break;
inc(P);
c := byte(P^);
until false;
if c=ord('-') then begin
minus := true;
repeat inc(P); c := byte(P^); until c<>ord(' ');
end else begin
minus := false;
if c=ord('+') then
repeat inc(P); c := byte(P^); until c<>ord(' ');
end;
dec(c,48);
if c>9 then
exit;
result := c;
repeat
inc(P);
c := byte(P^);
dec(c,48);
if c>9 then
break;
result := result*10+PtrInt(c);
until false;
if minus then
result := -result;
end;
function GetInteger(P,PEnd: PUTF8Char): PtrInt;
var c: byte;
minus: boolean;
begin
result := 0;
if (P=nil) or (P>=PEnd) then
exit;
c := byte(P^);
repeat
if c=0 then
exit;
if c>ord(' ') then
break;
inc(P);
if P=PEnd then
exit;
c := byte(P^);
until false;
if c=ord('-') then begin
minus := true;
repeat inc(P); if P=PEnd then exit; c := byte(P^); until c<>ord(' ');
end else begin
minus := false;
if c=ord('+') then
repeat inc(P); if P=PEnd then exit; c := byte(P^); until c<>ord(' ');
end;
dec(c,48);
if c>9 then
exit;
result := c;
repeat
inc(P);
if P=PEnd then
break;
c := byte(P^);
dec(c,48);
if c>9 then
break;
result := result*10+PtrInt(c);
until false;
if minus then
result := -result;
end;
function GetInteger(P: PUTF8Char; var err: integer): PtrInt;
var c: byte;
minus: boolean;
begin
result := 0;
err := 1; // don't return the exact index, just 1 as error flag
if P=nil then
exit;
c := byte(P^);
repeat
if c=0 then
exit;
if c>ord(' ') then
break;
inc(P);
c := byte(P^);
until false;
if c=ord('-') then begin
minus := true;
repeat inc(P); c := byte(P^); until c<>ord(' ');
end else begin
minus := false;
if c=ord('+') then
repeat inc(P); c := byte(P^); until c<>ord(' ');
end;
dec(c,48);
if c>9 then
exit;
result := c;
repeat
inc(P);
c := byte(P^);
dec(c,48);
if c<=9 then
result := result*10+PtrInt(c) else
if c<>256-48 then
exit else
break;
until false;
err := 0; // success
if minus then
result := -result;
end;
function GetIntegerDef(P: PUTF8Char; Default: PtrInt): PtrInt;
var err: integer;
begin
result := GetInteger(P,err);
if err<>0 then
result := Default;
end;
function 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 ToInteger(const text: RawUTF8; out value: integer): boolean;
var err: integer;
begin
value := GetInteger(pointer(text),err);
result := err=0;
end;
function ToCardinal(const text: RawUTF8; out value: cardinal; minimal: cardinal): boolean;
begin
value := GetCardinalDef(pointer(text),cardinal(-1));
result := (value<>cardinal(-1)) and (value>=minimal);
end;
function ToInt64(const text: RawUTF8; out value: Int64): boolean;
var err: integer;
begin
value := GetInt64(pointer(text),err);
result := err=0;
end;
function ToDouble(const text: RawUTF8; out value: double): boolean;
var err: integer;
begin
value := GetExtended(pointer(text),err);
result := err=0;
end;
function UTF8ToInt64(const text: RawUTF8; const default: Int64): Int64;
var err: integer;
begin
result := GetInt64(pointer(text),err);
if err<>0 then
result := default;
end;
function GetBoolean(P: PUTF8Char): boolean;
begin
if P<>nil then
case PInteger(P)^ of
TRUE_LOW: result := true;
FALSE_LOW: result := false;
else result := PWord(P)^<>ord('0');
end else
result := false;
end;
function GetCardinalDef(P: PUTF8Char; Default: PtrUInt): PtrUInt;
var c: byte;
begin
result := Default;
if P=nil then
exit;
c := byte(P^);
repeat
if c=0 then
exit;
if c>ord(' ') then
break;
inc(P);
c := byte(P^);
until false;
dec(c,48);
if c>9 then
exit;
result := c;
repeat
inc(P);
c := byte(P^)-48;
if c>9 then
break;
result := result*10+PtrUInt(c);
until false;
end;
function GetCardinal(P: PUTF8Char): PtrUInt;
var c: byte;
begin
result := 0;
if P=nil then
exit;
c := byte(P^);
repeat
if c=0 then
exit;
if c>ord(' ') then
break;
inc(P);
c := byte(P^);
until false;
dec(c,48);
if c>9 then
exit;
result := c;
repeat
inc(P);
c := byte(P^);
dec(c,48);
if c>9 then
break;
result := result*10+PtrUInt(c);
until false;
end;
function GetCardinalW(P: PWideChar): PtrUInt;
var c: PtrUInt;
begin
result := 0;
if P=nil then
exit;
c := ord(P^);
repeat
if c=0 then
exit;
if c>ord(' ') then
break;
inc(P);
c := ord(P^);
until false;
dec(c,48);
if c>9 then
exit;
result := c;
repeat
inc(P);
c := ord(P^);
dec(c,48);
if c>9 then
break;
result := result*10+c;
until false;
end;
{$ifdef CPU64}
procedure SetInt64(P: PUTF8Char; var result: Int64);
begin // PtrInt is already int64 -> call PtrInt version
result := GetInteger(P);
end;
{$else}
procedure SetInt64(P: PUTF8Char; var result: Int64);
var c: cardinal;
minus: boolean;
begin
result := 0;
if P=nil then
exit;
while (P^<=' ') and (P^<>#0) do inc(P);
if P^='-' then begin
minus := true;
repeat inc(P) until P^<>' ';
end else begin
minus := false;
if P^='+' then
repeat inc(P) until P^<>' ';
end;
c := byte(P^)-48;
if c>9 then
exit;
PCardinal(@result)^ := c;
inc(P);
repeat // fast 32-bit loop
c := byte(P^)-48;
if c>9 then
break else
PCardinal(@result)^ := PCardinal(@result)^*10+c;
inc(P);
if PCardinal(@result)^>=high(cardinal)div 10 then begin
repeat // 64-bit loop
c := byte(P^)-48;
if c>9 then
break;
result := result shl 3+result+result; // fast result := result*10
inc(result,c);
inc(P);
until false;
break;
end;
until false;
if minus then
result := -result;
end;
{$endif}
{$ifdef CPU64}
procedure SetQWord(P: PUTF8Char; var result: QWord);
begin // PtrUInt is already QWord -> call PtrUInt version
result := GetCardinal(P);
end;
{$else}
procedure SetQWord(P: PUTF8Char; var result: QWord);
var c: cardinal;
begin
result := 0;
if P=nil then
exit;
while (P^<=' ') and (P^<>#0) do inc(P);
if P^='+' then
repeat inc(P) until P^<>' ';
c := byte(P^)-48;
if c>9 then
exit;
PCardinal(@result)^ := c;
inc(P);
repeat // fast 32-bit loop
c := byte(P^)-48;
if c>9 then
break else
PCardinal(@result)^ := PCardinal(@result)^*10+c;
inc(P);
if PCardinal(@result)^>=high(cardinal)div 10 then begin
repeat // 64-bit loop
c := byte(P^)-48;
if c>9 then
break;
result := result shl 3+result+result; // fast result := result*10
inc(result,c);
inc(P);
until false;
break;
end;
until false;
end;
{$endif}
{$ifdef CPU64}
function GetInt64(P: PUTF8Char): Int64;
begin // PtrInt is already int64 -> call previous version
result := GetInteger(P);
end;
{$else}
function GetInt64(P: PUTF8Char): Int64;
begin
SetInt64(P,result);
end;
{$endif}
function GetInt64Def(P: PUTF8Char; const Default: Int64): Int64;
var err: integer;
begin
result := GetInt64(P,err);
if err>0 then
result := Default;
end;
{$ifdef CPU64}
function GetInt64(P: PUTF8Char; var err: integer): Int64;
begin // PtrInt is already int64 -> call previous version
result := GetInteger(P,err);
end;
{$else}
function GetInt64(P: PUTF8Char; var err: integer): Int64;
var c: cardinal;
minus: boolean;
begin
err := 0;
result := 0;
if P=nil then
exit;
while (P^<=' ') and (P^<>#0) do inc(P);
if P^='-' then begin
minus := true;
repeat inc(P) until P^<>' ';
end else begin
minus := false;
if P^='+' then
repeat inc(P) until P^<>' ';
end;
inc(err);
c := byte(P^)-48;
if c>9 then
exit;
PCardinal(@result)^ := c;
inc(P);
repeat // fast 32-bit loop
c := byte(P^);
if c<>0 then begin
dec(c,48);
inc(err);
if c>9 then
exit;
PCardinal(@result)^ := PCardinal(@result)^*10+c;
inc(P);
if PCardinal(@result)^>=high(cardinal)div 10 then begin
repeat // 64-bit loop
c := byte(P^);
if c=0 then begin
err := 0; // conversion success without error
break;
end;
dec(c,48);
inc(err);
if c>9 then
exit else
{$ifdef CPU32DELPHI}
result := result shl 3+result+result;
{$else}
result := result*10;
{$endif}
inc(result,c);
if result<0 then
exit; // overflow (>$7FFFFFFFFFFFFFFF)
inc(P);
until false;
break;
end;
end else begin
err := 0; // reached P^=#0 -> conversion success without error
break;
end;
until false;
if minus then
result := -result;
end;
{$endif}
function GetQWord(P: PUTF8Char; var err: integer): QWord;
var c: PtrUInt;
begin
err := 1; // error
result := 0;
if P=nil then
exit;
while (P^<=' ') and (P^<>#0) do inc(P);
c := byte(P^)-48;
if c>9 then
exit;
{$ifdef CPU64}
result := c;
inc(P);
repeat
c := byte(P^);
if c=0 then
break;
dec(c,48);
if c>9 then
exit;
result := result*10+c;
inc(P);
until false;
err := 0; // success
{$else}
PByte(@result)^ := c;
inc(P);
repeat // fast 32-bit loop
c := byte(P^);
if c<>0 then begin
dec(c,48);
inc(err);
if c>9 then
exit;
PCardinal(@result)^ := PCardinal(@result)^*10+c;
inc(P);
if PCardinal(@result)^>=high(cardinal)div 10 then begin
repeat // 64-bit loop
c := byte(P^);
if c=0 then begin
err := 0; // conversion success without error
break;
end;
dec(c,48);
inc(err);
if c>9 then
exit else
{$ifdef CPU32DELPHI}
result := result shl 3+result+result;
{$else}
result := result*10;
{$endif}
inc(result,c);
inc(P);
until false;
break;
end;
end else begin
err := 0; // reached P^=#0 -> conversion success without error
break;
end;
until false;
{$endif CPU64}
end;
function GetExtended(P: PUTF8Char): TSynExtended;
var err: integer;
begin
result := GetExtended(P,err);
if err<>0 then
result := 0;
end;
const POW10: array[-31..33] of TSynExtended = (
1E-31,1E-30,1E-29,1E-28,1E-27,1E-26,1E-25,1E-24,1E-23,1E-22,1E-21,1E-20,
1E-19,1E-18,1E-17,1E-16,1E-15,1E-14,1E-13,1E-12,1E-11,1E-10,1E-9,1E-8,1E-7,
1E-6,1E-5,1E-4,1E-3,1E-2,1E-1,1E0,1E1,1E2,1E3,1E4,1E5,1E6,1E7,1E8,1E9,1E10,
1E11,1E12,1E13,1E14,1E15,1E16,1E17,1E18,1E19,1E20,1E21,1E22,1E23,1E24,1E25,
1E26,1E27,1E28,1E29,1E30,1E31,0,-1);
function HugePower10(exponent: integer): TSynExtended; {$ifdef HASINLINE}inline;{$endif}
var e: TSynExtended;
begin
result := POW10[0];
if exponent<0 then begin
e := POW10[-1];
exponent := -exponent;
end else
e := POW10[1];
repeat
while exponent and 1=0 do begin
exponent := exponent shr 1;
e := sqr(e);
end;
result := result*e;
dec(exponent);
until exponent=0;
end;
function GetExtended(P: PUTF8Char; out err: integer): TSynExtended;
{$ifndef CPU32DELPHI}
var digit: byte;
frac, exp: PtrInt;
c: AnsiChar;
flags: set of (fNeg, fNegExp, fValid);
v: Int64; // allows 64-bit resolution for the digits
label e;
begin
byte(flags) := 0;
v := 0;
frac := 0;
if P=nil then
goto e;
c := P^;
if c=' ' then
repeat
inc(P);
c := P^;
until c<>' '; // trailing spaces
if c='+' then begin
inc(P);
c := P^;
end else
if c='-' then begin
inc(P);
c := P^;
include(flags,fNeg);
end;
digit := 18; // max Int64 resolution
repeat
inc(P);
if (c>='0') and (c<='9') then begin
if digit <> 0 then begin
dec(c,ord('0'));
{$ifdef CPU64}
v := v*10;
{$else}
v := v shl 3+v+v;
{$endif}
inc(v,byte(c));
dec(digit); // over-required digits are just ignored
include(flags,fValid);
if frac<>0 then
dec(frac);
end else
if frac>=0 then
inc(frac); // handle #############00000
c := P^;
continue;
end;
if c<>'.' then
break;
if frac>0 then
goto e;
dec(frac);
c := P^;
until false;
if frac<0 then
inc(frac);
if (c='E') or (c='e') then begin
exp := 0;
exclude(flags,fValid);
c := P^;
if c='+' then
inc(P) else
if c='-' then begin
inc(P);
include(flags,fNegExp);
end;
repeat
c := P^;
inc(P);
if (c<'0') or (c>'9') then
break;
dec(c,ord('0'));
exp := (exp*10)+byte(c);
include(flags,fValid);
until false;
if fNegExp in flags then
dec(frac,exp) else
inc(frac,exp);
end;
if (fValid in flags) and (c=#0) then
err := 0 else
e: err := 1; // return the (partial) value even if not ended with #0
if (frac>=-31) and (frac<=31) then
result := POW10[frac] else
result := HugePower10(frac);
if fNeg in flags then
result := result*POW10[33]; // *-1
result := result*v;
end;
{$else}
const Ten: double = 10.0;
asm // in: eax=text, edx=@err out: st(0)=result
push ebx // save used registers
push esi
push edi
mov esi, eax // string pointer
push eax // save for error condition
xor ebx, ebx
push eax // allocate local storage for loading fpu
test esi, esi
jz @nil // nil string
@trim: movzx ebx, byte ptr[esi] // strip leading spaces
inc esi
cmp bl, ' '
je @trim
xor ecx, ecx // clear sign flag
fld qword[Ten] // load 10 into fpu
xor eax, eax // zero number of decimal places
fldz // zero result in fpu
cmp bl, '0'
jl @chksig // check for sign character
@dig1: xor edi, edi // zero exponent value
@digl: sub bl, '0'
cmp bl, 9
ja @frac // non-digit
mov cl, 1 // set digit found flag
mov [esp], ebx // store for fpu use
fmul st(0), st(1) // multply by 10
fiadd dword ptr[esp] // add next digit
movzx ebx, byte ptr[esi] // get next char
inc esi
test bl, bl // end reached?
jnz @digl // no,get next digit
jmp @finish // yes,finished
@chksig:cmp bl, '-'
je @minus
cmp bl, '+'
je @sigset
@gdig1: test bl, bl
jz @error // no digits found
jmp @dig1
@minus: mov ch, 1 // set sign flag
@sigset:movzx ebx, byte ptr[esi] // get next char
inc esi
jmp @gdig1
@frac: cmp bl, '.' - '0'
jne @exp // no decimal point
movzx ebx, byte ptr[esi] // get next char
test bl, bl
jz @dotend // string ends with '.'
inc esi
@fracl: sub bl, '0'
cmp bl, 9
ja @exp // non-digit
mov [esp], ebx
dec eax // -(number of decimal places)
fmul st(0), st(1) // multply by 10
fiadd dword ptr[esp] // add next digit
movzx ebx, byte ptr[esi] // get next char
inc esi
test bl, bl // end reached?
jnz @fracl // no, get next digit
jmp @finish // yes, finished (no exponent)
@dotend:test cl, cl // any digits found before '.'?
jnz @finish // yes, valid
jmp @error // no,invalid
@exp: or bl, $20
cmp bl, 'e' - '0'
jne @error // not 'e' or 'e'
movzx ebx, byte ptr[esi] // get next char
inc esi
mov cl, 0 // clear exponent sign flag
cmp bl, '-'
je @minexp
cmp bl, '+'
je @expset
jmp @expl
@minexp:mov cl, 1 // set exponent sign flag
@expset:movzx ebx, byte ptr[esi] // get next char
inc esi
@expl: sub bl, '0'
cmp bl, 9
ja @error // non-digit
lea edi, [edi + edi * 4]// multiply by 10
add edi, edi
add edi, ebx // add next digit
movzx ebx, byte ptr[esi] // get next char
inc esi
test bl, bl // end reached?
jnz @expl // no, get next digit
@endexp:test cl, cl // positive exponent?
jz @finish // yes, keep exponent value
neg edi // no, negate exponent value
@finish:add eax, edi // exponent value - number of decimal places
mov [edx], ebx // result code = 0
jz @pow // no call to _pow10 needed
mov edi, ecx // save decimal sign flag
call System.@Pow10 // raise to power of 10
mov ecx, edi // restore decimal sign flag
@pow: test ch, ch // decimal sign flag set?
jnz @negate // yes, negate value
@ok: add esp, 8 // dump local storage and string pointer
@exit: ffree st(1) // remove ten value from fpu
pop edi // restore used registers
pop esi
pop ebx
ret // finished
@negate:fchs // negate result in fpu
jmp @ok
@nil: inc esi // force result code = 1
fldz // result value = 0
@error: pop ebx // dump local storage
pop eax // string pointer
sub esi, eax // error offset
mov [edx], esi // set result code
test ch, ch // decimal sign flag set?
jz @exit // no,exit
fchs // yes. negate result in fpu
jmp @exit // exit setting result code
end;
{$endif CPU32DELPHI}
function FloatStrCopy(s, d: PUTF8Char): PUTF8Char;
var c: AnsiChar;
begin
while s^=' ' do inc(s);
c := s^;
if (c='+') or (c='-') then begin
inc(s);
d^ := c;
inc(d);
c := s^;
end;
if c='.' then begin
PCardinal(d)^ := ord('0')+ord('.')shl 8; // '.5' -> '0.5'
inc(d,2);
inc(s);
c := s^;
end;
if (c>='0') and (c<='9') then
repeat
inc(s);
d^ := c;
inc(d);
c := s^;
if ((c>='0') and (c<='9')) or (c='.') then
continue;
if (c<>'e') and (c<>'E') then
break;
inc(s);
d^ := c; // 1.23e120 or 1.23e-45
inc(d);
c := s^;
if c='-' then begin
inc(s);
d^ := c;
inc(d);
c := s^;
end;
while (c>='0') and (c<='9') do begin
inc(s);
d^ := c;
inc(d);
c := s^;
end;
break;
until false;
result := d;
end;
function GetUTF8Char(P: PUTF8Char): cardinal;
begin
if P<>nil then begin
result := ord(P[0]);
if result and $80<>0 then begin
result := GetHighUTF8UCS4(P);
if result>$ffff then
result := ord('?'); // do not handle surrogates now
end;
end else
result := PtrUInt(P);
end;
function NextUTF8UCS4(var P: PUTF8Char): cardinal;
begin
if P<>nil then begin
result := byte(P[0]);
if result<=127 then
inc(P) else begin
if result and $20=0 then begin
result := result shl 6+byte(P[1])-$3080; // fast direct process $0..$7ff
inc(P,2);
end else
result := GetHighUTF8UCS4(P); // handle even surrogates
end;
end else
result := 0;
end;
function ContainsUTF8(p, up: PUTF8Char): boolean;
var u: PByte;
begin
if (p<>nil) and (up<>nil) and (up^<>#0) then begin
result := true;
repeat
u := pointer(up);
repeat
if GetNextUTF8Upper(p)<>u^ then
break else
inc(u);
if u^=0 then
exit; // up^ was found inside p^
until false;
p := FindNextUTF8WordBegin(p);
until p=nil;
end;
result := false;
end;
function IdemFileExt(p: PUTF8Char; extup: PAnsiChar; sepChar: AnsiChar): Boolean;
var ext: PUTF8Char;
begin
if (p<>nil) and (extup<>nil) then begin
ext := nil;
repeat
if p^=sepChar then
ext := p; // get last '.' position from p into ext
inc(p);
until p^=#0;
result := IdemPChar(ext,extup);
end else
result := false;
end;
function IdemFileExts(p: PUTF8Char; const extup: array of PAnsiChar;
sepChar: AnsiChar): integer;
var ext: PUTF8Char;
begin
result := -1;
if (p<>nil) and (high(extup)>0) then begin
ext := nil;
repeat
if p^=sepChar then
ext := p; // get last '.' position from p into ext
inc(p);
until p^=#0;
if ext<>nil then
result := IdemPCharArray(ext,extup);
end;
end;
function IdemPCharWithoutWhiteSpace(p: PUTF8Char; up: PAnsiChar): boolean;
begin
result := False;
if p=nil then
exit;
if up<>nil then
while up^<>#0 do begin
while p^<=' ' do // trim white space
if p^=#0 then
exit else
inc(p);
if up^<>NormToUpperAnsi7[p^] then
exit;
inc(up);
inc(p);
end;
result := true;
end;
function IdemPCharArray(p: PUTF8Char; const upArray: array of PAnsiChar): integer;
var w: word;
tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperAnsi7{$else}PNormTableByte{$endif};
up: ^PAnsiChar;
begin
if p<>nil then begin
{$ifndef CPUX86NOTPIC}tab := @NormToUpperAnsi7;{$endif} // faster on PIC and x86_64
w := tab[ord(p[0])]+tab[ord(p[1])]shl 8;
up := @upArray[0];
for result := 0 to high(upArray) do
if (PWord(up^)^=w) and
{$ifdef CPUX86NOTPIC}IdemPChar({$else}IdemPChar2(pointer(tab),{$endif}p+2,up^+2) then
exit else
inc(up);
end;
result := -1;
end;
function IdemPCharArray(p: PUTF8Char; const upArrayBy2Chars: RawUTF8): integer;
var w: word;
begin
if p<>nil then begin
w := NormToUpperAnsi7Byte[ord(p[0])]+NormToUpperAnsi7Byte[ord(p[1])]shl 8;
for result := 0 to pred(length(upArrayBy2Chars) shr 1) do
if PWordArray(upArrayBy2Chars)[result]=w then
exit;
end;
result := -1;
end;
function IdemPCharU(p, up: PUTF8Char): boolean;
begin
result := false;
if (p=nil) or (up=nil) then
exit;
while up^<>#0 do begin
if GetNextUTF8Upper(p)<>ord(up^) then
exit;
inc(up);
end;
result := true;
end;
function EndWith(const text, upText: RawUTF8): boolean;
var o: PtrInt;
begin
o := length(text)-length(upText);
result := (o>=0) and IdemPChar(PUTF8Char(pointer(text))+o,pointer(upText));
end;
function EndWithArray(const text: RawUTF8; const upArray: array of RawUTF8): integer;
var t,o: PtrInt;
begin
t := length(text);
if t>0 then
for result := 0 to high(upArray) do begin
o := t-length(UpArray[result]);
if (o>=0) and IdemPChar(PUTF8Char(pointer(text))+o,pointer(upArray[result])) then
exit;
end;
result := -1;
end;
function UpperCopy255(dest: PAnsiChar; const source: RawUTF8): PAnsiChar;
begin
if source<>'' then
result := UpperCopy255Buf(dest,pointer(source),PStrLen(PtrUInt(source)-_STRLEN)^) else
result := dest;
end;
function UpperCopy255BufPas(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar;
var i,c,d{$ifdef CPU64},_80,_61,_7b{$endif}: PtrUInt;
begin
if sourceLen>0 then begin
if sourceLen>248 then
sourceLen := 248; // avoid buffer overflow
// we allow to copy up to 3/7 more chars in Dest^ since its size is 255
{$ifdef CPU64} // unbranched uppercase conversion of 8 chars blocks
_80 := PtrUInt($8080808080808080); // use registers for constants
_61 := $6161616161616161;
_7b := $7b7b7b7b7b7b7b7b;
for i := 0 to (sourceLen-1) shr 3 do begin
c := PPtrUIntArray(source)^[i];
d := c or _80;
PPtrUIntArray(dest)^[i] := c-((d-PtrUInt(_61)) and not(d-_7b)) and
((not c) and _80)shr 2;
end;
{$else} // unbranched uppercase conversion of 4 chars blocks
for i := 0 to (sourceLen-1) shr 2 do begin
c := PPtrUIntArray(source)^[i];
d := c or PtrUInt($80808080);
PPtrUIntArray(dest)^[i] := c-((d-PtrUInt($61616161)) and not(d-PtrUInt($7b7b7b7b))) and
((not c) and PtrUInt($80808080))shr 2;
end;
{$endif}
result := dest+sourceLen; // but we always return the exact size
end else
result := dest;
end;
function UpperCopyWin255(dest: PWinAnsiChar; const source: RawUTF8): PWinAnsiChar;
var i, L: PtrInt;
tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperByte{$else}PNormTableByte{$endif};
begin
if source='' then
result := dest else begin
L := PStrLen(PtrUInt(source)-_STRLEN)^;
if L>250 then
L := 250; // avoid buffer overflow
result := dest+L;
{$ifndef CPUX86NOTPIC}tab := @NormToUpperByte;{$endif} // faster on PIC and x86_64
for i := 0 to L-1 do
dest[i] := AnsiChar(tab[PByteArray(source)[i]]);
end;
end;
function UTF8UpperCopy(Dest, Source: PUTF8Char; SourceChars: Cardinal): PUTF8Char;
var c: cardinal;
endSource, endSourceBy4, up: PUTF8Char;
extra,i: PtrInt;
label By1, By4, set1; // ugly but faster
begin
if (Source<>nil) and (Dest<>nil) then begin
// first handle trailing 7 bit ASCII chars, by quad (Sha optimization)
endSource := Source+SourceChars;
endSourceBy4 := endSource-4;
up := @NormToUpper;
if (PtrUInt(Source) and 3=0) and (Source<=endSourceBy4) then
repeat
By4:c := PCardinal(Source)^;
if c and $80808080<>0 then
goto By1; // break on first non ASCII quad
inc(Source,4);
Dest[0] := up[ToByte(c)];
Dest[1] := up[ToByte(c shr 8)];
Dest[2] := up[ToByte(c shr 16)];
Dest[3] := up[ToByte(c shr 24)];
inc(Dest,4);
until Source>endSourceBy4;
// generic loop, handling one UCS4 char per iteration
if Source<endSource then
repeat
By1:c := byte(Source^);
inc(Source);
if c<=127 then begin
Dest^ := up[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 (up[c]<=#127) then begin
Dest^ := up[c];
inc(Source,extra);
goto set1;
end;
Dest^ := Source[-1];
repeat // here we now extra>0 - just copy UTF-8 input untouched
inc(Dest);
Dest^ := Source^;
inc(Source);
dec(extra);
if extra=0 then
goto Set1;
until false;
end;
until false;
end;
result := Dest;
end;
function UTF8UpperCopy255(dest: PAnsiChar; const source: RawUTF8): PUTF8Char;
var L: integer;
begin
L := length(source);
if L>0 then begin
if L>250 then
L := 250; // avoid buffer overflow
result := UTF8UpperCopy(pointer(dest),pointer(source),L);
end else
result := pointer(dest);
end;
function UpperCopy255W(dest: PAnsiChar; const source: SynUnicode): PAnsiChar;
var c: cardinal;
i,L: integer;
begin
L := length(source);
if L>0 then begin
if L>250 then
L := 250; // avoid buffer overflow
result := dest+L;
for i := 0 to L-1 do begin
c := PWordArray(source)[i];
if c<255 then
dest[i] := AnsiChar(NormToUpperAnsi7Byte[c]) else
dest[i] := '?';
end;
end else
result := dest;
end;
function UpperCopy255W(dest: PAnsiChar; source: PWideChar; L: integer): PAnsiChar;
var c: cardinal;
i: integer;
begin
if L>0 then begin
if L>250 then
L := 250; // avoid buffer overflow
result := dest+L;
for i := 0 to L-1 do begin
c := PWordArray(source)[i];
if c<255 then
dest[i] := AnsiChar(NormToUpperAnsi7Byte[c]) else
dest[i] := '?';
end;
end else
result := dest;
end;
function GetNextLine(source: PUTF8Char; out next: PUTF8Char; andtrim: boolean): RawUTF8;
var beg: PUTF8Char;
begin
if source=nil then begin
{$ifdef FPC}Finalize(result){$else}result := ''{$endif};
next := source;
exit;
end;
if andtrim then // optional trim left
while source^ in [#9,' '] do inc(source);
beg := source;
repeat // just here to avoid a goto
if source[0]>#13 then
if source[1]>#13 then
if source[2]>#13 then
if source[3]>#13 then begin
inc(source,4); // fast process 4 chars per loop
continue;
end else
inc(source,3) else
inc(source,2) else
inc(source);
case source^ of
#0: next := nil;
#10: next := source+1;
#13: if source[1]=#10 then next := source+2 else next := source+1;
else begin
inc(source);
continue;
end;
end;
if andtrim then // optional trim right
while (source>beg) and (source[-1] in [#9,' ']) do dec(source);
FastSetString(result,beg,source-beg);
exit;
until false;
end;
{$ifdef UNICODE}
function GetNextLineW(source: PWideChar; out next: PWideChar): string;
begin
next := source;
if source=nil then begin
result := '';
exit;
end;
while not (cardinal(source^) in [0,10,13]) do inc(source);
SetString(result,PChar(next),source-next);
if source^=#13 then inc(source);
if source^=#10 then inc(source);
if source^=#0 then
next := nil else
next := source;
end;
function FindIniNameValueW(P: PWideChar; UpperName: PUTF8Char): string;
var PBeg: PWideChar;
L: PtrInt;
begin
while (P<>nil) and (P^<>'[') do begin
PBeg := P;
while not (cardinal(P^) in [0,10,13]) do inc(P);
while cardinal(P^) in [10,13] do inc(P);
if P^=#0 then P := nil;
if PBeg^=' ' then repeat inc(PBeg) until PBeg^<>' '; // trim left ' '
if IdemPCharW(PBeg,UpperName) then begin
inc(PBeg,StrLen(UpperName));
L := 0; while PBeg[L]>=' ' do inc(L); // get line length
SetString(result,PBeg,L);
exit;
end;
end;
result := '';
end;
function FindIniEntryW(const Content: string; const Section, Name: RawUTF8): string;
var P: PWideChar;
UpperSection, UpperName: array[byte] of AnsiChar;
// possible GPF if length(Section/Name)>255, but should const in code
begin
result := '';
P := pointer(Content);
if P=nil then exit;
// UpperName := UpperCase(Name)+'=';
PWord(UpperCopy255(UpperName,Name))^ := ord('=');
if Section='' then
// find the Name= entry before any [Section]
result := FindIniNameValueW(P,UpperName) else begin
// find the Name= entry in the specified [Section]
PWord(UpperCopy255(UpperSection,Section))^ := ord(']');
if FindSectionFirstLineW(P,UpperSection) then
result := FindIniNameValueW(P,UpperName);
end;
end;
{$endif UNICODE}
function IdemPCharAndGetNextItem(var source: PUTF8Char; const searchUp: RawUTF8;
var Item: RawUTF8; Sep: AnsiChar): boolean;
begin
if source=nil then
result := false else begin
result := IdemPChar(source,Pointer(searchUp));
if result then begin
inc(source,Length(searchUp));
GetNextItem(source,Sep,Item);
end;
end;
end;
function GotoNextLine(source: PUTF8Char): PUTF8Char;
label
_z, _0, _1, _2, _3; // ugly but faster
var
c: AnsiChar;
begin
if source<>nil then
repeat
if source[0]<#13 then
goto _0
else if source[1]<#13 then
goto _1
else if source[2]<#13 then
goto _2
else if source[3]<#13 then
goto _3
else begin
inc(source, 4);
continue;
end;
_3: inc(source);
_2: inc(source);
_1: inc(source);
_0: c := source^;
if c=#13 then begin
if source[1]=#10 then begin
result := source+2; // most common case is text ending with #13#10
exit;
end;
end else
if c=#0 then
goto _z else
if c<>#10 then begin
inc(source);
continue; // e.g. #9
end;
result := source+1;
exit;
until false;
_z: result := nil;
end;
function BufferLineLength(Text, TextEnd: PUTF8Char): PtrInt;
{$ifdef CPUX64}
{$ifdef FPC} nostackframe; assembler; asm {$else} asm .noframe {$endif}
{$ifdef MSWINDOWS} // Win64 ABI to System-V ABI
push rsi
push rdi
mov rdi, rcx
mov rsi, rdx
{$endif}mov r8, rsi
sub r8, rdi // rdi=Text, rsi=TextEnd, r8=TextLen
jz @fail
mov ecx, edi
movaps xmm0, [rip + @for10]
movaps xmm1, [rip + @for13]
and rdi, -16 // check first aligned 16 bytes
and ecx, 15 // lower cl 4 bits indicate misalignment
movaps xmm2, [rdi]
movaps xmm3, xmm2
pcmpeqb xmm2, xmm0
pcmpeqb xmm3, xmm1
por xmm3, xmm2
pmovmskb eax, xmm3
shr eax, cl // shift out unaligned bytes
test eax, eax
jz @main
bsf eax, eax
add rax, rcx
add rax, rdi
sub rax, rsi
jae @fail // don't exceed TextEnd
add rax, r8 // rax = TextFound - TextEnd + (TextEnd - Text) = offset
{$ifdef MSWINDOWS}
pop rdi
pop rsi
{$endif}ret
@main: add rdi, 16
sub rdi, rsi
jae @fail
jmp @by16
{$ifdef FPC} align 16 {$else} .align 16 {$endif}
@for10: dq $0a0a0a0a0a0a0a0a
dq $0a0a0a0a0a0a0a0a
@for13: dq $0d0d0d0d0d0d0d0d
dq $0d0d0d0d0d0d0d0d
@by16: movaps xmm2, [rdi + rsi] // check 16 bytes per loop
movaps xmm3, xmm2
pcmpeqb xmm2, xmm0
pcmpeqb xmm3, xmm1
por xmm3, xmm2
pmovmskb eax, xmm3
test eax, eax
jnz @found
add rdi, 16
jnc @by16
@fail: mov rax, r8 // returns TextLen if no CR/LF found
{$ifdef MSWINDOWS}
pop rdi
pop rsi
{$endif}ret
@found: bsf eax, eax
add rax, rdi
jc @fail
add rax, r8
{$ifdef MSWINDOWS}
pop rdi
pop rsi
{$endif}
end;
{$else}
begin
result := PtrUInt(Text)-1;
repeat
inc(result);
if PtrUInt(result)<PtrUInt(TextEnd) then
if (PByte(result)^>13) or ((PByte(result)^<>10) and (PByte(result)^<>13)) then
continue;
break;
until false;
dec(result,PtrInt(Text)); // returns length
end;
{$endif CPUX64}
function GetLineSize(P, PEnd: PUTF8Char): PtrUInt;
var c: byte;
begin
{$ifdef CPUX64}
if PEnd <> nil then begin
result := BufferLineLength(P,PEnd); // use branchless SSE2 on x86_64
exit;
end;
result := PtrUInt(P)-1;
{$else}
result := PtrUInt(P)-1;
if PEnd<>nil then
repeat // inlined BufferLineLength()
inc(result);
if PtrUInt(result)<PtrUInt(PEnd) then begin
c := PByte(result)^;
if (c>13) or ((c<>10) and (c<>13)) then
continue;
end;
break;
until false else
{$endif CPUX64}
repeat // inlined BufferLineLength() ending at #0 for PEnd=nil
inc(result);
c := PByte(result)^;
if (c>13) or ((c<>0) and (c<>10) and (c<>13)) then
continue;
break;
until false;
dec(result,PtrUInt(P)); // returns length
end;
function GetNextItem(var P: PUTF8Char; Sep: AnsiChar): RawUTF8;
begin
GetNextItem(P,Sep,result);
end;
procedure GetNextItem(var P: PUTF8Char; Sep: AnsiChar; var result: RawUTF8);
var S: PUTF8Char;
begin
if P=nil then
result := '' else begin
S := P;
while (S^<>#0) and (S^<>Sep) do
inc(S);
FastSetString(result,P,S-P);
if S^<>#0 then
P := S+1 else
P := nil;
end;
end;
procedure GetNextItem(var P: PUTF8Char; Sep, Quote: AnsiChar; var result: RawUTF8);
begin
if P=nil then
result := ''
else if P^=Quote then begin
P := UnQuoteSQLStringVar(P,result);
if P=nil then
result := ''
else if P^<>#0 then
inc(P);
end else
GetNextItem(P,Sep,result);
end;
procedure GetNextItemTrimed(var P: PUTF8Char; Sep: AnsiChar; var result: RawUTF8);
var S,E: PUTF8Char;
begin
if (P=nil) or (Sep<=' ') then
result := '' else begin
while (P^<=' ') and (P^<>#0) do inc(P); // trim left
S := P;
while (S^<>#0) and (S^<>Sep) do
inc(S);
E := S;
while (E>P) and (E[-1] in [#1..' ']) do dec(E); // trim right
FastSetString(result,P,E-P);
if S^<>#0 then
P := S+1 else
P := nil;
end;
end;
procedure GetNextItemTrimedCRLF(var P: PUTF8Char; var result: RawUTF8);
var S,E: PUTF8Char;
begin
if P=nil then
result := '' else begin
S := P;
while (S^<>#0) and (S^<>#10) do
inc(S);
E := S;
if (E>P) and (E[-1]=#13) then
dec(E);
FastSetString(result,P,E-P);
if S^<>#0 then
P := S+1 else
P := nil;
end;
end;
function GetNextItemString(var P: PChar; Sep: Char): string;
// this function will compile into AnsiString or UnicodeString, depending
// of the compiler version
var S: PChar;
begin
if P=nil then
result := '' else begin
S := P;
while (S^<>#0) and (S^<>Sep) do
inc(S);
SetString(result,P,S-P);
if S^<>#0 then
P := S+1 else
P := nil;
end;
end;
function GetNextStringLineToRawUnicode(var P: PChar): RawUnicode;
var S: PChar;
begin
if P=nil then
result := '' else begin
S := P;
while S^>=' ' do
inc(S);
result := StringToRawUnicode(P,S-P);
while (S^<>#0) and (S^<' ') do inc(S); // ignore e.g. #13 or #10
if S^<>#0 then
P := S else
P := nil;
end;
end;
procedure AppendCSVValues(const CSV: string; const Values: array of string;
var Result: string; const AppendBefore: string);
var Caption: string;
i, bool: integer;
P: PChar;
first: Boolean;
begin
P := pointer(CSV);
if P=nil then
exit;
first := True;
for i := 0 to high(Values) do begin
Caption := GetNextItemString(P);
if Values[i]<>'' then begin
if first then begin
Result := Result+#13#10;
first := false;
end else
Result := Result+AppendBefore;
bool := FindCSVIndex('0,-1',RawUTF8(Values[i]));
Result := Result+Caption+': ';
if bool<0 then
Result := Result+Values[i] else
Result := Result+GetCSVItemString(pointer(GetNextItemString(P)),bool,'/');
end;
end;
end;
procedure GetNextItemShortString(var P: PUTF8Char; out Dest: ShortString; Sep: AnsiChar);
var S: PUTF8Char;
len: PtrInt;
begin
S := P;
if S<>nil then begin
while (S^<=' ') and (S^<>#0) do inc(S);
P := S;
if (S^<>#0) and (S^<>Sep) then
repeat
inc(S);
until (S^=#0) or (S^=Sep);
len := S-P;
repeat
dec(len);
until (len<0) or not(P[len] in [#1..' ']); // trim right spaces
if len>=255 then
len := 255 else
inc(len);
Dest[0] := AnsiChar(len);
MoveSmall(P,@Dest[1],Len);
if S^<>#0 then
P := S+1 else
P := nil;
end else
Dest[0] := #0;
end;
function GetNextItemHexDisplayToBin(var P: PUTF8Char; Bin: PByte; BinBytes: integer;
Sep: AnsiChar): boolean;
var S: PUTF8Char;
len: integer;
begin
result := false;
FillCharFast(Bin^,BinBytes,0);
if P=nil then
exit;
if P^=' ' then repeat inc(P) until P^<>' ';
S := P;
if Sep=#0 then
while S^>' ' do
inc(S) else
while (S^<>#0) and (S^<>Sep) do
inc(S);
len := S-P;
while (P[len-1] in [#1..' ']) and (len>0) do dec(len); // trim right spaces
if len<>BinBytes*2 then
exit;
if not HexDisplayToBin(PAnsiChar(P),Bin,BinBytes) then
FillCharFast(Bin^,BinBytes,0) else begin
if S^=#0 then
P := nil else
if Sep<>#0 then
P := S+1 else
P := S;
result := true;
end;
end;
function GetNextItemCardinal(var P: PUTF8Char; Sep: AnsiChar): PtrUInt;
var c: PtrUInt;
begin
if P=nil then begin
result := 0;
exit;
end;
if P^=' ' then repeat inc(P) until P^<>' ';
c := byte(P^)-48;
if c>9 then
result := 0 else begin
result := c;
inc(P);
repeat
c := byte(P^)-48;
if c>9 then
break else
result := result*10+c;
inc(P);
until false;
end;
if Sep<>#0 then
while (P^<>#0) and (P^<>Sep) do // go to end of CSV item (ignore any decimal)
inc(P);
if P^=#0 then
P := nil else
if Sep<>#0 then
inc(P);
end;
function GetNextItemCardinalStrict(var P: PUTF8Char): PtrUInt;
var c: PtrUInt;
begin
if P=nil then begin
result := 0;
exit;
end;
c := byte(P^)-48;
if c>9 then
result := 0 else begin
result := c;
inc(P);
repeat
c := byte(P^)-48;
if c>9 then
break else
result := result*10+c;
inc(P);
until false;
end;
if P^=#0 then
P := nil;
end;
function CSVOfValue(const Value: RawUTF8; Count: cardinal; const Sep: RawUTF8): RawUTF8;
var ValueLen, SepLen: cardinal;
i: cardinal;
P: PAnsiChar;
begin // CSVOfValue('?',3)='?,?,?'
result := '';
if Count=0 then
exit;
ValueLen := length(Value);
SepLen := Length(Sep);
FastSetString(result,nil,ValueLen*Count+SepLen*pred(Count));
P := pointer(result);
i := 1;
repeat
if ValueLen>0 then begin
MoveSmall(Pointer(Value),P,ValueLen);
inc(P,ValueLen);
end;
if i=Count then
break;
if SepLen>0 then begin
MoveSmall(Pointer(Sep),P,SepLen);
inc(P,SepLen);
end;
inc(i);
until false;
// assert(P-pointer(result)=length(result));
end;
procedure SetBitCSV(var Bits; BitsCount: integer; var P: PUTF8Char);
var bit,last: cardinal;
begin
while P<>nil do begin
bit := GetNextItemCardinalStrict(P)-1; // '0' marks end of list
if bit>=cardinal(BitsCount) then
break; // avoid GPF
if (P=nil) or (P^=',') then
SetBitPtr(@Bits,bit) else
if P^='-' then begin
inc(P);
last := GetNextItemCardinalStrict(P)-1; // '0' marks end of list
if last>=Cardinal(BitsCount) then
exit;
while bit<=last do begin
SetBitPtr(@Bits,bit);
inc(bit);
end;
end;
if (P<>nil) and (P^=',') then
inc(P);
end;
if (P<>nil) and (P^=',') then
inc(P);
end;
function GetBitCSV(const Bits; BitsCount: integer): RawUTF8;
var i,j: integer;
begin
result := '';
i := 0;
while i<BitsCount do
if GetBitPtr(@Bits,i) then begin
j := i;
while (j+1<BitsCount) and GetBitPtr(@Bits,j+1) do
inc(j);
result := result+UInt32ToUtf8(i+1);
if j=i then
result := result+',' else
if j=i+1 then
result := result+','+UInt32ToUtf8(j+1)+',' else
result := result+'-'+UInt32ToUtf8(j+1)+',';
i := j+1;
end else
inc(i);
result := result+'0'; // '0' marks end of list
end;
function GetNextItemCardinalW(var P: PWideChar; Sep: WideChar= ','): PtrUInt;
var c: PtrUInt;
begin
if P=nil then begin
result := 0;
exit;
end;
c := word(P^)-48;
if c>9 then
result := 0 else begin
result := c;
inc(P);
repeat
c := word(P^)-48;
if c>9 then
break else
result := result*10+c;
inc(P);
until false;
end;
while (P^<>#0) and (P^<>Sep) do // go to end of CSV item (ignore any decimal)
inc(P);
if P^=#0 then
P := nil else
inc(P);
end;
function GetNextItemInteger(var P: PUTF8Char; Sep: AnsiChar): PtrInt;
var minus: boolean;
begin
if P=nil then begin
result := 0;
exit;
end;
if P^=' ' then repeat inc(P) until P^<>' ';
if (P^ in ['+','-']) then begin
minus := P^='-';
inc(P);
end else
minus := false;
result := PtrInt(GetNextItemCardinal(P,Sep));
if minus then
result := -result;
end;
function GetNextTChar64(var P: PUTF8Char; Sep: AnsiChar; out Buf: TChar64): PtrInt;
var S: PUTF8Char;
c: AnsiChar;
begin
result := 0;
S := P;
if S=nil then
exit;
if Sep=#0 then
repeat // store up to next whitespace
c := S[result];
if c<=' ' then break;
Buf[result] := c;
inc(result);
if result>=SizeOf(Buf) then
exit; // avoid buffer overflow
until false else
repeat // store up to Sep or end of string
c := S[result];
if (c=#0) or (c=Sep) then break;
Buf[result] := c;
inc(result);
if result>=SizeOf(Buf) then
exit; // avoid buffer overflow
until false;
Buf[result] := #0; // make asciiz
inc(S,result); // S[result]=Sep or #0
if S^=#0 then
P := nil else
if Sep=#0 then
P := S else
P := S+1;
end;
function GetNextItemInt64(var P: PUTF8Char; Sep: AnsiChar): Int64;
{$ifdef CPU64}
begin
result := GetNextItemInteger(P,Sep); // PtrInt=Int64
end;
{$else}
var tmp: TChar64;
begin
if GetNextTChar64(P,Sep,tmp)>0 then
SetInt64(tmp,result) else
result := 0;
end;
{$endif}
function GetNextItemQWord(var P: PUTF8Char; Sep: AnsiChar): QWord;
{$ifdef CPU64}
begin
result := GetNextItemCardinal(P,Sep); // PtrUInt=QWord
end;
{$else}
var tmp: TChar64;
begin
if GetNextTChar64(P,Sep,tmp)>0 then
SetQWord(tmp,result) else
result := 0;
end;
{$endif}
function GetNextItemHexa(var P: PUTF8Char; Sep: AnsiChar): QWord;
var tmp: TChar64;
L: integer;
begin
result := 0;
L := GetNextTChar64(P,Sep,tmp);
if (L>0) and (L and 1=0) then
if not HexDisplayToBin(@tmp,@result,L shr 1) then
result := 0;
end;
function GetNextItemDouble(var P: PUTF8Char; Sep: AnsiChar): double;
var tmp: TChar64;
err: integer;
begin
if GetNextTChar64(P,Sep,tmp)>0 then begin
result := GetExtended(tmp,err);
if err<>0 then
result := 0;
end else
result := 0;
end;
function GetNextItemCurrency(var P: PUTF8Char; Sep: AnsiChar): currency;
begin
GetNextItemCurrency(P,result,Sep);
end;
procedure GetNextItemCurrency(var P: PUTF8Char; out result: currency; Sep: AnsiChar);
var tmp: TChar64;
begin
if GetNextTChar64(P,Sep,tmp)>0 then
PInt64(@result)^ := StrToCurr64(tmp) else
result := 0;
end;
function GetCSVItem(P: PUTF8Char; Index: PtrUInt; Sep: AnsiChar): RawUTF8;
var i: PtrUInt;
begin
if P=nil then
result := '' else
for i := 0 to Index do
GetNextItem(P,Sep,result);
end;
function GetUnQuoteCSVItem(P: PUTF8Char; Index: PtrUInt; Sep, Quote: AnsiChar): RawUTF8;
var i: PtrUInt;
begin
if P=nil then
result := '' else
for i := 0 to Index do
GetNextItem(P,Sep,Quote,result);
end;
function GetLastCSVItem(const CSV: RawUTF8; Sep: AnsiChar): RawUTF8;
var i: integer;
begin
for i := length(CSV) downto 1 do
if CSV[i]=Sep then begin
result := copy(CSV,i+1,maxInt);
exit;
end;
result := CSV;
end;
function GetCSVItemString(P: PChar; Index: PtrUInt; Sep: Char): string;
var i: PtrUInt;
begin
if P=nil then
result := '' else
for i := 0 to Index do
result := GetNextItemString(P,Sep);
end;
function FindCSVIndex(CSV: PUTF8Char; const Value: RawUTF8; Sep: AnsiChar;
CaseSensitive,TrimValue: boolean): integer;
var s: RawUTF8;
begin
result := 0;
while CSV<>nil do begin
GetNextItem(CSV,Sep,s);
if TrimValue then
s := trim(s);
if CaseSensitive then begin
if s=Value then
exit;
end else
if SameTextU(s,Value) then
exit;
inc(result);
end;
result := -1; // not found
end;
procedure CSVToRawUTF8DynArray(CSV: PUTF8Char; var Result: TRawUTF8DynArray;
Sep: AnsiChar; TrimItems, AddVoidItems: boolean);
var s: RawUTF8;
n: integer;
begin
n := length(Result);
while CSV<>nil do begin
if TrimItems then
GetNextItemTrimed(CSV,Sep,s) else
GetNextItem(CSV,Sep,s);
if (s<>'') or AddVoidItems then
AddRawUTF8(Result,n,s);
end;
if n<>length(Result) then
SetLength(Result,n);
end;
procedure CSVToRawUTF8DynArray(const CSV,Sep,SepEnd: RawUTF8; var Result: TRawUTF8DynArray);
var offs,i: integer;
begin
offs := 1;
while offs<=length(CSV) do begin
SetLength(Result,length(Result)+1);
i := PosEx(Sep,CSV,offs);
if i=0 then begin
i := PosEx(SepEnd,CSV,offs);
if i=0 then
i := MaxInt else
dec(i,offs);
Result[high(Result)] := Copy(CSV,offs,i);
exit;
end;
Result[high(Result)] := Copy(CSV,offs,i-offs);
offs := i+length(sep);
end;
end;
function AddPrefixToCSV(CSV: PUTF8Char; const Prefix: RawUTF8; Sep: AnsiChar): RawUTF8;
var s: RawUTF8;
begin
GetNextItem(CSV,Sep,result);
if result='' then
exit;
result := Prefix+result;
while CSV<>nil do begin
GetNextItem(CSV,Sep,s);
if s<>'' then
result := result+','+Prefix+s;
end;
end;
procedure AddToCSV(const Value: RawUTF8; var CSV: RawUTF8; const Sep: RawUTF8);
begin
if CSV='' then
CSV := Value else
CSV := CSV+Sep+Value;
end;
function RenameInCSV(const OldValue, NewValue: RawUTF8; var CSV: RawUTF8;
const Sep: RawUTF8): boolean;
var pattern: RawUTF8;
i,j: integer;
begin
result := OldValue=NewValue;
i := length(OldValue);
if result or (length(Sep)<>1) or (length(CSV)<i) or
(PosEx(Sep,OldValue)>0) or (PosEx(Sep,NewValue)>0) then
exit;
if CompareMem(pointer(OldValue),pointer(CSV),i) and // first (or unique) item
((CSV[i+1]=Sep[1]) or (CSV[i+1]=#0)) then
i := 1 else begin
j := 1;
pattern := Sep+OldValue;
repeat
i := PosEx(pattern,CSV,j);
if i=0 then
exit;
j := i+length(pattern);
until (CSV[j]=Sep[1]) or (CSV[j]=#0);
inc(i);
end;
delete(CSV,i,length(OldValue));
insert(NewValue,CSV,i);
result := true;
end;
function RawUTF8ArrayToCSV(const Values: array of RawUTF8; const Sep: RawUTF8): RawUTF8;
var i, len, seplen, L: Integer;
P: PAnsiChar;
begin
result := '';
if high(Values)<0 then
exit;
seplen := length(Sep);
len := seplen*high(Values);
for i := 0 to high(Values) do
inc(len,length(Values[i]));
FastSetString(result,nil,len);
P := pointer(result);
i := 0;
repeat
L := length(Values[i]);
if L>0 then begin
MoveFast(pointer(Values[i])^,P^,L);
inc(P,L);
end;
if i=high(Values) then
Break;
if seplen>0 then begin
MoveSmall(pointer(Sep),P,seplen);
inc(P,seplen);
end;
inc(i);
until false;
end;
function RawUTF8ArrayToQuotedCSV(const Values: array of RawUTF8; const Sep: RawUTF8;
Quote: AnsiChar): RawUTF8;
var i: integer;
tmp: TRawUTF8DynArray;
begin
SetLength(tmp,length(Values));
for i := 0 to High(Values) do
tmp[i] := QuotedStr(Values[i],Quote);
result := RawUTF8ArrayToCSV(tmp,Sep);
end;
function TRawUTF8DynArrayFrom(const Values: array of RawUTF8): TRawUTF8DynArray;
var i: integer;
begin
Finalize(result);
SetLength(result,length(Values));
for i := 0 to high(Values) do
result[i] := Values[i];
end;
{$ifdef HASCODEPAGE}
function LStringCodePage(info: PTypeInfo): integer; inline;
begin // caller checked that info^.kind=tkLString
result := PWord({$ifdef FPC}AlignTypeData{$endif}(pointer(PtrUInt(info)+info^.NameLen+2)))^;
end;
{$endif HASCODEPAGE}
function IsRawUTF8DynArray(typeinfo: pointer): boolean;
var nfo: PTypeInfo;
begin
if typeinfo=System.TypeInfo(TRawUTF8DynArray) then
result := true else begin
nfo := GetTypeInfo(typeinfo,tkDynArray);
if (nfo<>nil) and (nfo^.elSize=SizeOf(pointer)) and
(nfo^.elType<>nil) then begin
nfo := DeRef(nfo^.elType);
result := (nfo^.kind=tkLString)
{$ifdef HASCODEPAGE}and (LStringCodePage(nfo)=CP_UTF8){$endif};
end else
result := false;
end;
end;
procedure AddArrayOfConst(var Dest: TTVarRecDynArray; const Values: array of const);
var i,n: Integer;
begin
n := length(Dest);
SetLength(Dest,n+length(Values));
for i := 0 to high(Values) do
Dest[i+n] := Values[i];
end;
var
DefaultTextWriterTrimEnum: boolean;
function ObjectToJSON(Value: TObject; Options: TTextWriterWriteObjectOptions): RawUTF8;
var temp: TTextWriterStackBuffer;
begin
if Value=nil then
result := NULL_STR_VAR else
with DefaultTextWriterSerializer.CreateOwnedStream(temp) do
try
include(fCustomOptions,twoForceJSONStandard);
WriteObject(Value,Options);
SetText(result);
finally
Free;
end;
end;
function ObjectsToJSON(const Names: array of RawUTF8; const Values: array of TObject;
Options: TTextWriterWriteObjectOptions): RawUTF8;
var i,n: integer;
temp: TTextWriterStackBuffer;
begin
with DefaultTextWriterSerializer.CreateOwnedStream(temp) do
try
n := length(Names);
Add('{');
for i := 0 to high(Values) do
if Values[i]<>nil then begin
if i<n then
AddFieldName(Names[i]) else
AddPropName(ClassNameShort(Values[i])^);
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;
procedure _UrlEncode_Write(s, p: PByte; tab: PTextByteSet);
var c: cardinal;
hex: ^TByteToWord;
begin
hex := @TwoDigitsHexWB;
repeat
c := s^;
inc(s);
if tcURIUnreserved in tab[c] then begin
p^ := c; // cf. rfc3986 2.3. Unreserved Characters
inc(p);
end else
if c=0 then
exit else
if c=32 then begin
p^ := ord('+');
inc(p);
end else begin
p^ := ord('%'); inc(p);
PWord(p)^ := hex[c];
inc(p,2);
end;
until false;
end;
function _UrlEncode_ComputeLen(s: PByte; tab: PTextByteSet): PtrInt;
var c: cardinal;
begin
result := 0;
repeat
c := s^;
inc(s);
if (tcURIUnreserved in tab[c]) or (c=32) then begin
inc(result);
continue;
end;
if c=0 then
exit;
inc(result,3);
until false;
end;
function UrlEncode(Text: PUTF8Char): RawUTF8;
begin
result := '';
if Text=nil then
exit;
FastSetString(result,nil,_UrlEncode_ComputeLen(pointer(Text),@TEXT_CHARS));
_UrlEncode_Write(pointer(Text),pointer(result),@TEXT_BYTES);
end;
function UrlEncode(const NameValuePairs: array of const): RawUTF8;
// (['select','*','where','ID=12','offset',23,'object',aObject]);
var A, n: PtrInt;
name, value: RawUTF8;
begin
result := '';
n := high(NameValuePairs);
if (n>0) and (n and 1=1) then begin
for A := 0 to n shr 1 do begin
VarRecToUTF8(NameValuePairs[A*2],name);
if not IsUrlValid(pointer(name)) then
continue; // just skip invalid names
with NameValuePairs[A*2+1] do
if VType=vtObject then
value := ObjectToJSON(VObject,[]) else
VarRecToUTF8(NameValuePairs[A*2+1],value);
result := result+'&'+name+'='+UrlEncode(value);
end;
result[1] := '?';
end;
end;
function IsUrlValid(P: PUTF8Char): boolean;
var tab: PTextCharSet;
begin
result := false;
if P=nil then
exit;
tab := @TEXT_CHARS;
repeat // cf. rfc3986 2.3. Unreserved Characters
if tcURIUnreserved in tab[P^] then
inc(P) else
exit;
until P^=#0;
result := true;
end;
function AreUrlValid(const Url: array of RawUTF8): boolean;
var i: integer;
begin
result := false;
for i := 0 to high(Url) do
if not IsUrlValid(pointer(Url[i])) then
exit;
result := true;
end;
function IncludeTrailingURIDelimiter(const URI: RawByteString): RawByteString;
begin
if (URI<>'') and (URI[length(URI)]<>'/') then
result := URI+'/' else
result := URI;
end;
function UrlEncodeJsonObject(const URIName: RawUTF8; ParametersJSON: PUTF8Char;
const PropNamesToIgnore: array of RawUTF8; IncludeQueryDelimiter: Boolean): RawUTF8;
var i,j: integer;
sep: AnsiChar;
Params: TNameValuePUTF8CharDynArray;
temp: TTextWriterStackBuffer;
begin
if ParametersJSON=nil then
result := URIName else
with TTextWriter.CreateOwnedStream(temp) do
try
AddString(URIName);
if (JSONDecode(ParametersJSON,Params,true)<>nil) and (Params<>nil) then begin
sep := '?';
for i := 0 to length(Params)-1 do
with Params[i] do begin
for j := 0 to high(PropNamesToIgnore) do
if IdemPropNameU(PropNamesToIgnore[j],Name,NameLen) then begin
NameLen := 0;
break;
end;
if NameLen=0 then
continue;
if IncludeQueryDelimiter then
Add(sep);
AddNoJSONEscape(Name,NameLen);
Add('=');
AddString(UrlEncode(Value));
sep := '&';
IncludeQueryDelimiter := true;
end;
end;
SetText(result);
finally
Free;
end;
end;
function UrlEncodeJsonObject(const URIName, ParametersJSON: RawUTF8;
const PropNamesToIgnore: array of RawUTF8; IncludeQueryDelimiter: Boolean): RawUTF8;
var temp: TSynTempBuffer;
begin
temp.Init(ParametersJSON);
try
result := UrlEncodeJsonObject(URIName,temp.buf,PropNamesToIgnore,IncludeQueryDelimiter);
finally
temp.Done;
end;
end;
function UrlDecode(const s: RawUTF8; i,len: PtrInt): RawUTF8;
var L: PtrInt;
P: PUTF8Char;
tmp: TSynTempBuffer;
begin
result := '';
L := PtrInt(s);
if L=0 then
exit;
L := PStrLen(L-_STRLEN)^;
if len<0 then
len := L;
if i>L then
exit;
dec(i);
if len=i then
exit;
P := tmp.Init(len-i); // reserve enough space for result
while 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;
tmp.Done(P,result);
end;
function UrlDecode(U: PUTF8Char): RawUTF8;
var P: PUTF8Char;
L: integer;
tmp: TSynTempBuffer;
begin
result := '';
L := StrLen(U);
if L=0 then
exit;
P := tmp.Init(L);
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;
tmp.Done(P,result);
end;
function UrlDecodeNextValue(U: PUTF8Char; out Value: RawUTF8): PUTF8Char;
var Beg,V: PUTF8Char;
len: 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
if len<>0 then begin
FastSetString(Value,nil,len);
V := pointer(Value);
U := Beg;
repeat
if (U^='%') and HexToChar(PAnsiChar(U+1),V) then begin
inc(V);
inc(U,3);
end else begin
if U^='+' then
V^ := ' ' else
V^ := U^;
inc(V);
inc(U);
end;
dec(len);
until len=0;
end;
end;
result := U;
end;
function UrlDecodeNextName(U: PUTF8Char; out Name: RawUTF8): PUTF8Char;
var Beg, V: PUTF8Char;
len: PtrInt;
begin
result := nil;
if U=nil then
exit;
// compute resulting length of name
Beg := U;
len := 0;
repeat
case U^ of
#0: exit;
'=': begin
result := U+1;
break;
end;
'%': if (U[1]='3') and (U[2] in ['D','d']) then begin
result := U+3;
break; // %3d means = according to the RFC
end else
if HexToCharValid(PAnsiChar(U+1)) then
inc(U,3) else
inc(U);
else inc(U);
end;
inc(len);
until false;
if len=0 then
exit;
// decode name content
FastSetString(Name,nil,len);
V := pointer(Name);
U := Beg;
repeat
if (U^='%') and HexToChar(PAnsiChar(U+1),V) then begin
inc(V);
inc(U,3);
end else begin
if U^='+' then
V^ := ' ' else
V^ := U^;
inc(V);
inc(U);
end;
dec(len);
until len=0;
end;
function UrlDecodeNextNameValue(U: PUTF8Char; var Name,Value: RawUTF8): PUTF8Char;
begin
result := nil;
if U=nil then
exit;
U := UrlDecodeNextName(U,Name);
if U=nil then
exit;
U := UrlDecodeNextValue(U,Value);
if U^=#0 then
result := U else
result := U+1; // jump '&' to let decode the next name=value pair
end;
function UrlDecodeValue(U: PUTF8Char; const Upper: RawUTF8; var Value: RawUTF8;
Next: PPUTF8Char): boolean;
begin
// UrlDecodeValue('select=%2A&where=LastName%3D%27M%C3%B4net%27','SELECT=',V,@U)
// -> U^='where=...' and V='*'
result := false; // mark value not modified by default
if U=nil then begin
if Next<>nil then
Next^ := U;
exit;
end;
if IdemPChar(U,pointer(Upper)) then begin
result := true;
inc(U,length(Upper));
U := UrlDecodeNextValue(U,Value);
end;
if Next=nil then
exit;
while not(U^ in [#0,'&']) do inc(U);
if U^=#0 then
Next^ := nil else
Next^ := U+1; // jump '&'
end;
function UrlDecodeInteger(U: PUTF8Char; const Upper: RawUTF8;
var Value: integer; Next: PPUTF8Char): boolean;
var V: PtrInt;
SignNeg: boolean;
begin
// UrlDecodeInteger('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next)
// -> Next^='where=...' and O=20
result := false; // mark value not modified by default
if U=nil then begin
if Next<>nil then
Next^ := U;
exit;
end;
if IdemPChar(U,pointer(Upper)) then begin
inc(U,length(Upper));
if U^='-' then begin
SignNeg := True;
Inc(U);
end else
SignNeg := false;
if U^ in ['0'..'9'] then begin
V := 0;
repeat
V := (V*10)+ord(U^)-48;
inc(U);
until not (U^ in ['0'..'9']);
if SignNeg then
Value := -V else
Value := V;
result := true;
end;
end;
if Next=nil then
exit;
while not(U^ in [#0,'&']) do inc(U);
if U^=#0 then
Next^ := nil else
Next^ := U+1; // jump '&'
end;
function UrlDecodeCardinal(U: PUTF8Char; const Upper: RawUTF8;
var Value: Cardinal; Next: PPUTF8Char): boolean;
var V: PtrInt;
begin
// UrlDecodeInteger('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next)
// -> Next^='where=...' and O=20
result := false; // mark value not modified by default
if U=nil then begin
if Next<>nil then
Next^ := U;
exit;
end;
if IdemPChar(U,pointer(Upper)) then begin
inc(U,length(Upper));
if U^ in ['0'..'9'] then begin
V := 0;
repeat
V := (V*10)+ord(U^)-48;
inc(U);
until not (U^ in ['0'..'9']);
Value := V;
result := true;
end;
end;
if Next=nil then
exit;
while not(U^ in [#0,'&']) do inc(U);
if U^=#0 then
Next^ := nil else
Next^ := U+1; // jump '&'
end;
function UrlDecodeInt64(U: PUTF8Char; const Upper: RawUTF8;
var Value: Int64; Next: PPUTF8Char): boolean;
var tmp: RawUTF8;
begin
result := UrlDecodeValue(U,Upper,tmp,Next);
if result then
SetInt64(pointer(tmp),Value);
end;
function UrlDecodeExtended(U: PUTF8Char; const Upper: RawUTF8;
var Value: TSynExtended; Next: PPUTF8Char): boolean;
var tmp: RawUTF8;
err: integer;
begin
result := UrlDecodeValue(U,Upper,tmp,Next);
if result then begin
Value := GetExtended(pointer(tmp),err);
if err<>0 then
result := false;
end;
end;
function UrlDecodeDouble(U: PUTF8Char; const Upper: RawUTF8; var Value: double;
Next: PPUTF8Char): boolean;
var tmp: RawUTF8;
err: integer;
begin
result := UrlDecodeValue(U,Upper,tmp,Next);
if result then begin
Value := GetExtended(pointer(tmp),err);
if err<>0 then
result := false;
end;
end;
function UrlDecodeNeedParameters(U, CSVNames: PUTF8Char): boolean;
var tmp: array[byte] of AnsiChar;
L: integer;
Beg: PUTF8Char;
// UrlDecodeNeedParameters('price=20.45&where=LastName%3D','price,where') will
// return TRUE
begin
result := (CSVNames=nil);
if result then
exit; // no parameter to check -> success
if U=nil then
exit; // no input data -> error
repeat
L := 0;
while (CSVNames^<>#0) and (CSVNames^<>',') do begin
tmp[L] := NormToUpper[CSVNames^];
if L=high(tmp) then
exit else // invalid CSV parameter
inc(L);
inc(CSVNames);
end;
if L=0 then
exit; // invalid CSV parameter
PWord(@tmp[L])^ := ord('=');
Beg := U;
repeat
if IdemPChar(U,tmp) then
break;
while not(U^ in [#0,'&']) do inc(U);
if U^=#0 then
exit else // didn't find tmp in U
inc(U); // Jump &
until false;
U := Beg;
if CSVNames^=#0 then
Break else // no more parameter to check
inc(CSVNames); // jump &
until false;
result := true; // all parameters found
end;
function CSVEncode(const NameValuePairs: array of const;
const KeySeparator, ValueSeparator: RawUTF8): RawUTF8;
var i: integer;
temp: TTextWriterStackBuffer;
begin
if length(NameValuePairs)<2 then
result := '' else
with DefaultTextWriterSerializer.CreateOwnedStream(temp) do
try
for i := 1 to length(NameValuePairs) shr 1 do begin
Add(NameValuePairs[i*2-2],twNone);
AddNoJSONEscape(pointer(KeySeparator),length(KeySeparator));
Add(NameValuePairs[i*2-1],twNone);
AddNoJSONEscape(pointer(ValueSeparator),length(ValueSeparator));
end;
SetText(result);
finally
Free;
end;
end;
function ArrayOfConstValueAsText(const NameValuePairs: array of const;
const aName: RawUTF8): RawUTF8;
var i: integer;
name: RawUTF8;
begin
for i := 1 to length(NameValuePairs) shr 1 do
if VarRecToUTF8IsString(NameValuePairs[i*2-2],name) and
IdemPropNameU(name,aName) then begin
VarRecToUTF8(NameValuePairs[i*2-1],result);
exit;
end;
result := '';
end;
function IsZero(P: pointer; Length: integer): boolean;
var i: integer;
begin
result := false;
for i := 1 to Length shr 4 do // 16 bytes (4 DWORD) by loop - aligned read
{$ifdef CPU64}
if (PInt64Array(P)^[0]<>0) or (PInt64Array(P)^[1]<>0) then
{$else}
if (PCardinalArray(P)^[0]<>0) or (PCardinalArray(P)^[1]<>0) or
(PCardinalArray(P)^[2]<>0) or (PCardinalArray(P)^[3]<>0) then
{$endif}
exit else
inc(PByte(P),16);
for i := 1 to (Length shr 2)and 3 do // 4 bytes (1 DWORD) by loop
if PCardinal(P)^<>0 then
exit else
inc(PByte(P),4);
for i := 1 to Length and 3 do // remaining content
if PByte(P)^<>0 then
exit else
inc(PByte(P));
result := true;
end;
function IsZeroSmall(P: pointer; Length: PtrInt): boolean;
begin
result := false;
repeat
if PByte(P)^<>0 then
exit;
inc(PByte(P));
dec(Length);
if Length=0 then
break;
until false;
result := true;
end;
function IsZero(const Values: TRawUTF8DynArray): boolean;
var i: integer;
begin
result := false;
for i := 0 to length(Values)-1 do
if Values[i]<>'' then
exit;
result := true;
end;
function IsZero(const Values: TIntegerDynArray): boolean;
var i: integer;
begin
result := false;
for i := 0 to length(Values)-1 do
if Values[i]<>0 then
exit;
result := true;
end;
function IsZero(const Values: TInt64DynArray): boolean;
var i: integer;
begin
result := false;
for i := 0 to length(Values)-1 do
if Values[i]<>0 then
exit;
result := true;
end;
procedure FillZero(var Values: TRawUTF8DynArray);
var i: integer;
begin
for i := 0 to length(Values)-1 do
{$ifdef FPC}Finalize(Values[i]){$else}Values[i] := ''{$endif};
end;
procedure FillZero(var Values: TIntegerDynArray);
begin
FillCharFast(Values[0],length(Values)*SizeOf(integer),0);
end;
procedure FillZero(var Values: TInt64DynArray);
begin
FillCharFast(Values[0],length(Values)*SizeOf(Int64),0);
end;
function crc16(Data: PAnsiChar; Len: integer): cardinal;
var i, j: Integer;
begin
result := $ffff;
for i := 0 to Len-1 do begin
result := result xor (ord(Data[i]) shl 8);
for j := 1 to 8 do
if result and $8000<>0 then
result := (result shl 1) xor $1021 else
result := result shl 1;
end;
result := result and $ffff;
end;
function Hash32(const Text: RawByteString): cardinal;
begin
result := Hash32(pointer(Text),length(Text));
end;
function Hash32(Data: PCardinalArray; Len: integer): cardinal;
{$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler;
asm {$else} asm .noframe {$endif} // rcx/rdi=Data edx/esi=Len
xor eax, eax
xor r9d, r9d
test Data, Data
jz @z
{$ifdef win64}
mov r8, rdx
shr r8, 4
{$else}
mov edx, esi
shr esi, 4
{$endif}
jz @by4
{$ifdef FPC} align 16 {$else} .align 16 {$endif}
@by16: add eax, dword ptr[Data]
add r9d, eax
add eax, dword ptr[Data+4]
add r9d, eax
add eax, dword ptr[Data+8]
add r9d, eax
add eax, dword ptr[Data+12]
add r9d, eax
add Data, 16
{$ifdef win64}
dec r8d
{$else}
dec esi
{$endif}
jnz @by16
@by4: mov dh, dl
and dl, 15
jz @0
shr dl, 2
jz @rem
@4: add eax, dword ptr[Data]
add r9d, eax
add Data, 4
dec dl
jnz @4
@rem: and dh, 3
jz @0
dec dh
jz @1
dec dh
jz @2
mov ecx, dword ptr[Data]
and ecx, $ffffff
jmp @e
@2: movzx ecx, word ptr[Data]
jmp @e
@1: movzx ecx, byte ptr[Data]
@e: add eax, ecx
@0: add r9d, eax
shl r9d, 16
xor eax, r9d
@z:
end;
{$else}
{$ifdef PUREPASCAL}
var s1,s2: cardinal;
i: integer;
begin
if Data<>nil then begin
s1 := 0;
s2 := 0;
for i := 1 to Len shr 4 do begin // 16 bytes (128-bit) loop - aligned read
inc(s1,Data[0]);
inc(s2,s1);
inc(s1,Data[1]);
inc(s2,s1);
inc(s1,Data[2]);
inc(s2,s1);
inc(s1,Data[3]);
inc(s2,s1);
Data := @Data[4];
end;
for i := 1 to (Len shr 2)and 3 do begin // 4 bytes (DWORD) by loop
inc(s1,Data[0]);
inc(s2,s1);
Data := @Data[1];
end;
case Len and 3 of // remaining 0..3 bytes
1: inc(s1,PByte(Data)^);
2: inc(s1,PWord(Data)^);
3: inc(s1,PWord(Data)^ or (PByteArray(Data)^[2] shl 16));
end;
inc(s2,s1);
result := s1 xor (s2 shl 16);
end else
result := 0;
end;
{$else} {$ifdef FPC} nostackframe; assembler; {$endif}
asm // eax=Data edx=Len
push esi
push edi
mov cl, dl
mov ch, dl
xor esi, esi
xor edi, edi
test eax, eax
jz @z
shr edx, 4
jz @by4
nop
@by16: add esi, dword ptr[eax]
add edi, esi
add esi, dword ptr[eax+4]
add edi, esi
add esi, dword ptr[eax+8]
add edi, esi
add esi, dword ptr[eax+12]
add edi, esi
add eax, 16
dec edx
jnz @by16
@by4: and cl, 15
jz @0
shr cl, 2
jz @rem
@4: add esi, dword ptr[eax]
add edi, esi
add eax, 4
dec cl
jnz @4
@rem: and ch, 3
jz @0
dec ch
jz @1
dec ch
jz @2
mov eax, dword ptr[eax]
and eax, $ffffff
jmp @e
@2: movzx eax, word ptr[eax]
jmp @e
@1: movzx eax, byte ptr[eax]
@e: add esi, eax
@0: add edi, esi
mov eax, esi
shl edi, 16
xor eax, edi
@z: pop edi
pop esi
end;
{$endif PUREPASCAL}
{$endif CPUX64}
procedure OrMemory(Dest,Source: PByteArray; size: PtrInt);
begin
while size>=SizeOf(PtrInt) do begin
dec(size,SizeOf(PtrInt));
PPtrInt(Dest)^ := PPtrInt(Dest)^ or PPtrInt(Source)^;
inc(PPtrInt(Dest));
inc(PPtrInt(Source));
end;
while size>0 do begin
dec(size);
Dest[size] := Dest[size] or Source[size];
end;
end;
procedure XorMemory(Dest,Source: PByteArray; size: PtrInt);
begin
while size>=SizeOf(PtrInt) do begin
dec(size,SizeOf(PtrInt));
PPtrInt(Dest)^ := PPtrInt(Dest)^ xor PPtrInt(Source)^;
inc(PPtrInt(Dest));
inc(PPtrInt(Source));
end;
while size>0 do begin
dec(size);
Dest[size] := Dest[size] xor Source[size];
end;
end;
procedure XorMemory(Dest,Source1,Source2: PByteArray; size: PtrInt);
begin
while size>=SizeOf(PtrInt) do begin
dec(size,SizeOf(PtrInt));
PPtrInt(Dest)^ := PPtrInt(Source1)^ xor PPtrInt(Source2)^;
inc(PPtrInt(Dest));
inc(PPtrInt(Source1));
inc(PPtrInt(Source2));
end;
while size>0 do begin
dec(size);
Dest[size] := Source1[size] xor Source2[size];
end;
end;
procedure AndMemory(Dest,Source: PByteArray; size: PtrInt);
begin
while size>=SizeOf(PtrInt) do begin
dec(size,SizeOf(PtrInt));
PPtrInt(Dest)^ := PPtrInt(Dest)^ and PPtrInt(Source)^;
inc(PPtrInt(Dest));
inc(PPtrInt(Source));
end;
while size>0 do begin
dec(size);
Dest[size] := Dest[size] and Source[size];
end;
end;
{$ifdef CPUINTEL} // use optimized x86/x64 asm versions for xxHash32
{$ifdef CPUX86}
function xxHash32(crc: cardinal; P: PAnsiChar; len: integer): cardinal;
{$ifdef FPC}nostackframe; assembler;{$endif}
asm
xchg edx, ecx
push ebp
push edi
lea ebp, [ecx+edx]
push esi
push ebx
sub esp, 8
mov ebx, eax
mov dword ptr [esp], edx
lea eax, [ebx+165667B1H]
cmp edx, 15
jbe @2
lea eax, [ebp-10H]
lea edi, [ebx+24234428H]
lea esi, [ebx-7A143589H]
mov dword ptr [esp+4H], ebp
mov edx, eax
lea eax, [ebx+61C8864FH]
mov ebp, edx
@1: mov edx, dword ptr [ecx]
imul edx, -2048144777
add edi, edx
rol edi, 13
imul edi, -1640531535
mov edx, dword ptr [ecx+4]
imul edx, -2048144777
add esi, edx
rol esi, 13
imul esi, -1640531535
mov edx, dword ptr [ecx+8]
imul edx, -2048144777
add ebx, edx
rol ebx, 13
imul ebx, -1640531535
mov edx, dword ptr [ecx+12]
lea ecx, [ecx+16]
imul edx, -2048144777
add eax, edx
rol eax, 13
imul eax, -1640531535
cmp ebp, ecx
jnc @1
rol edi, 1
rol esi, 7
rol ebx, 12
add esi, edi
mov ebp, dword ptr [esp+4H]
ror eax, 14
add ebx, esi
add eax, ebx
@2: lea esi, [ecx+4H]
add eax, dword ptr [esp]
cmp ebp, esi
jc @4
mov ebx, esi
nop
@3: imul edx, dword ptr [ebx-4H], -1028477379
add ebx, 4
add eax, edx
ror eax, 15
imul eax, 668265263
cmp ebp, ebx
jnc @3
lea edx, [ebp-4H]
sub edx, ecx
mov ecx, edx
and ecx, 0FFFFFFFCH
add ecx, esi
@4: cmp ebp, ecx
jbe @6
@5: movzx edx, byte ptr [ecx]
add ecx, 1
imul edx, 374761393
add eax, edx
rol eax, 11
imul eax, -1640531535
cmp ebp, ecx
jnz @5
nop
@6: mov edx, eax
add esp, 8
shr edx, 15
xor eax, edx
imul eax, -2048144777
pop ebx
pop esi
mov edx, eax
shr edx, 13
xor eax, edx
imul eax, -1028477379
pop edi
pop ebp
mov edx, eax
shr edx, 16
xor eax, edx
end;
{$endif CPUX86}
{$ifdef CPUX64}
function xxHash32(crc: cardinal; P: PAnsiChar; len: integer): cardinal;
{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe{$endif}
{$ifdef LINUX} // crc=rdi P=rsi len=rdx
mov r8, rdi
mov rcx, rsi
{$else} // crc=r8 P=rcx len=rdx
mov r10, r8
mov r8, rcx
mov rcx, rdx
mov rdx, r10
push rsi // Win64 expects those registers to be preserved
push rdi
{$endif}
// P=r8 len=rcx crc=rdx
push r12
push rbx
mov r12d, -1640531535
lea r10, [rcx+rdx]
lea eax, [r8+165667B1H]
cmp rdx, 15
jbe @2
lea rsi, [r10-10H]
lea ebx, [r8+24234428H]
lea edi, [r8-7A143589H]
lea eax, [r8+61C8864FH]
@1: imul r9d, dword ptr [rcx], -2048144777
add rcx, 16
imul r11d, dword ptr [rcx-0CH], -2048144777
add ebx, r9d
lea r9d, [r11+rdi]
rol ebx, 13
rol r9d, 13
imul ebx, r12d
imul edi, r9d, -1640531535
imul r9d, dword ptr [rcx-8H], -2048144777
add r8d, r9d
imul r9d, dword ptr [rcx-4H], -2048144777
rol r8d, 13
imul r8d, r12d
add eax, r9d
rol eax, 13
imul eax, r12d
cmp rsi, rcx
jnc @1
rol edi, 7
rol ebx, 1
rol r8d, 12
mov r9d, edi
ror eax, 14
add r9d, ebx
add r8d, r9d
add eax, r8d
@2: lea r9, [rcx+4H]
add eax, edx
cmp r10, r9
jc @4
mov r8, r9
@3: imul edx, dword ptr [r8-4H], -1028477379
add r8, 4
add eax, edx
ror eax, 15
imul eax, 668265263
cmp r10, r8
jnc @3
lea rdx, [r10-4H]
sub rdx, rcx
mov rcx, rdx
and rcx, 0FFFFFFFFFFFFFFFCH
add rcx, r9
@4: cmp r10, rcx
jbe @6
@5: movzx edx, byte ptr [rcx]
add rcx, 1
imul edx, 374761393
add eax, edx
rol eax, 11
imul eax, r12d
cmp r10, rcx
jnz @5
@6: mov edx, eax
shr edx, 15
xor eax, edx
imul eax, -2048144777
mov edx, eax
shr edx, 13
xor eax, edx
imul eax, -1028477379
mov edx, eax
shr edx, 16
xor eax, edx
pop rbx
pop r12
{$ifndef LINUX}
pop rdi
pop rsi
{$endif}
end;
{$endif CPUX64}
{$else not CPUINTEL}
const
PRIME32_1 = 2654435761;
PRIME32_2 = 2246822519;
PRIME32_3 = 3266489917;
PRIME32_4 = 668265263;
PRIME32_5 = 374761393;
{$ifdef FPC} // RolDWord is an intrinsic function under FPC :)
function Rol13(value: cardinal): cardinal; inline;
begin
result := RolDWord(value, 13);
end;
{$else}
{$ifdef HASINLINENOTX86}
function RolDWord(value: cardinal; count: integer): cardinal; inline;
begin
result := (value shl count) or (value shr (32-count));
end;
function Rol13(value: cardinal): cardinal; inline;
begin
result := (value shl 13) or (value shr 19);
end;
{$else}
function RolDWord(value: cardinal; count: integer): cardinal;
asm
mov cl, dl
rol eax, cl
end;
function Rol13(value: cardinal): cardinal;
asm
rol eax, 13
end;
{$endif HASINLINENOTX86}
{$endif FPC}
function xxHash32(crc: cardinal; P: PAnsiChar; len: integer): cardinal;
var c1, c2, c3, c4: cardinal;
PLimit, PEnd: PAnsiChar;
begin
PEnd := P + len;
if len >= 16 then begin
PLimit := PEnd - 16;
c3 := crc;
c2 := c3 + PRIME32_2;
c1 := c2 + PRIME32_1;
c4 := c3 - PRIME32_1;
repeat
c1 := PRIME32_1 * Rol13(c1 + PRIME32_2 * PCardinal(P)^);
c2 := PRIME32_1 * Rol13(c2 + PRIME32_2 * PCardinal(P+4)^);
c3 := PRIME32_1 * Rol13(c3 + PRIME32_2 * PCardinal(P+8)^);
c4 := PRIME32_1 * Rol13(c4 + PRIME32_2 * PCardinal(P+12)^);
inc(P, 16);
until not (P <= PLimit);
result := RolDWord(c1, 1) + RolDWord(c2, 7) + RolDWord(c3, 12) + RolDWord(c4, 18);
end else
result := crc + PRIME32_5;
inc(result, len);
while P + 4 <= PEnd do begin
inc(result, PCardinal(P)^ * PRIME32_3);
result := RolDWord(result, 17) * PRIME32_4;
inc(P, 4);
end;
while P < PEnd do begin
inc(result, PByte(P)^ * PRIME32_5);
result := RolDWord(result, 11) * PRIME32_1;
inc(P);
end;
result := result xor (result shr 15);
result := result * PRIME32_2;
result := result xor (result shr 13);
result := result * PRIME32_3;
result := result xor (result shr 16);
end;
{$endif CPUINTEL}
type
TRegisters = record
eax,ebx,ecx,edx: cardinal;
end;
{$ifdef CPUINTEL}
{$ifdef CPU64}
procedure GetCPUID(Param: Cardinal; var Registers: TRegisters);
{$ifdef FPC}nostackframe; assembler; asm {$else}
asm .noframe // ecx=param, rdx=Registers (Linux: edi,rsi)
{$endif FPC}
mov eax, Param
mov r9, Registers
mov r10, rbx // preserve rbx
xor ebx, ebx
xor ecx, ecx
xor edx, edx
cpuid
mov TRegisters(r9).&eax, eax
mov TRegisters(r9).&ebx, ebx
mov TRegisters(r9).&ecx, ecx
mov TRegisters(r9).&edx, edx
mov rbx, r10
end;
{$ifndef ABSOLUTEPASCAL}
const
CMP_RANGES = $44; // see https://msdn.microsoft.com/en-us/library/bb531425
_UpperCopy255BufSSE42: array[0..31] of AnsiChar =
'azazazazazazazaz ';
function UpperCopy255BufSSE42(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar;
{$ifdef FPC}nostackframe; assembler; asm {$else}
asm .noframe // rcx=dest, rdx=source, r8=len (Linux: rdi,rsi,rdx)
{$endif FPC}
{$ifdef win64}
mov rax, rcx
mov r9, rdx
mov rdx, r8
{$else}
mov rax, rdi
mov r9, rsi
{$endif}
lea rcx, [rip + _UpperCopy255BufSSE42]
test rdx, rdx
jz @z
movups xmm1, dqword ptr [rcx]
movups xmm3, dqword ptr [rcx + 16]
cmp rdx, 16
ja @big
// optimize the common case of sourceLen<=16
movups xmm2, [r9]
{$ifdef HASAESNI}
pcmpistrm xmm1, xmm2, CMP_RANGES // find in range a-z, return mask in xmm0
{$else}
db $66, $0F, $3A, $62, $CA, CMP_RANGES
{$endif}
pand xmm0, xmm3
pxor xmm2, xmm0
movups [rax], xmm2
add rax, rdx
@z: ret
@big: mov rcx, rax
cmp rdx, 240
jb @ok
mov rdx, 239
@ok: add rax, rdx // return end position with the exact size
shr rdx, 4
sub r9, rcx
add rdx, 1
{$ifdef FPC} align 16 {$else} .align 16{$endif}
@s: movups xmm2, [r9 + rcx]
{$ifdef HASAESNI}
pcmpistrm xmm1, xmm2, CMP_RANGES
{$else}
db $66, $0F, $3A, $62, $CA, CMP_RANGES
{$endif}
pand xmm0, xmm3
pxor xmm2, xmm0
movups [rcx], xmm2
add rcx, 16
dec rdx
jnz @s
end;
{$ifdef HASAESNI}
const
EQUAL_EACH = 8; // see https://msdn.microsoft.com/en-us/library/bb531463
NEGATIVE_POLARITY = 16;
function StrLenSSE42(S: pointer): PtrInt;
{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
xor rax, rax
mov rdx, S
test S, S
jz @null
xor rcx, rcx
pxor xmm0, xmm0
pcmpistri xmm0, [rdx], EQUAL_EACH // result in ecx
jnz @L
mov eax, ecx
@null: ret
{$ifdef FPC} align 16 {$else} .align 16 {$endif}
@L: add rax, 16 // add before comparison flag
pcmpistri xmm0, [rdx + rax], EQUAL_EACH // result in ecx
jnz @L
add rax, rcx
end;
function StrCompSSE42(Str1, Str2: pointer): PtrInt;
{$ifdef FPC}nostackframe; assembler; asm {$else}
asm .noframe // rcx=Str1, rdx=Str2 (Linux: rdi,rsi)
{$endif FPC}
{$ifdef win64}
mov rax, rcx
test rcx, rdx
{$else}
mov rax, rdi
mov rdx, rsi
test rdi, rsi // is one of Str1/Str2 nil ?
{$endif}
jz @n
@ok: sub rax, rdx
xor rcx, rcx
movups xmm0, dqword [rdx]
pcmpistri xmm0, dqword [rdx + rax], EQUAL_EACH + NEGATIVE_POLARITY // result in rcx
ja @1
jc @2
xor rax, rax
ret
{$ifdef FPC} align 16 {$else} .align 16 {$endif}
@1: add rdx, 16
movups xmm0, dqword [rdx]
pcmpistri xmm0, dqword [rdx + rax], EQUAL_EACH + NEGATIVE_POLARITY
ja @1
jc @2
@0: xor rax, rax // Str1=Str2
ret
@n: cmp rax, rdx
je @0
test rax, rax // Str1='' ?
jz @max
test rdx, rdx // Str2='' ?
jnz @ok
mov rax, 1
ret
@max: dec rax // returns -1
ret
@2: add rax, rdx
movzx rax, byte ptr [rax + rcx]
movzx rdx, byte ptr [rdx + rcx]
sub rax, rdx
end;
{$endif HASAESNI}
{$endif ABSOLUTEPASCAL}
function crc32csse42(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
{$ifdef FPC}nostackframe; assembler; asm {$else}
asm .noframe // ecx=crc, rdx=buf, r8=len (Linux: edi,rsi,edx)
{$endif FPC}
mov eax, crc
not eax
test len, len
jz @0
test buf, buf
jz @0
jmp @align
@7: crc32 eax, byte ptr[buf]
inc buf
dec len
jz @0
@align: test buf, 7
jnz @7
mov ecx, len
shr len, 3
jnz @s
@2: test cl, 4
jz @3
crc32 eax, dword ptr[buf]
add buf, 4
@3: test cl, 2
jz @1
crc32 eax, word ptr[buf]
add buf, 2
@1: test cl, 1
jz @0
crc32 eax, byte ptr[buf]
@0: not eax
ret
{$ifdef FPC} align 16
@s: crc32 rax, qword [buf] // hash 8 bytes per loop
{$else} .align 16
@s: db $F2,$48,$0F,$38,$F1,$02 // circumvent Delphi inline asm compiler bug
{$endif}add buf, 8
dec len
jnz @s
jmp @2
end;
function StrLenSSE2(S: pointer): PtrInt;
{$ifdef FPC}nostackframe; assembler; asm {$else}
asm .noframe // rcx=S (Linux: rdi)
{$endif FPC} // from GPL strlen64.asm by Agner Fog - www.agner.org/optimize
{$ifdef win64}
mov rax, rcx // get pointer to string from rcx
mov r8, rcx // copy pointer
test rcx, rcx
{$else}
mov rax, rdi
mov ecx, edi
test rdi, rdi
{$endif}
jz @null // returns 0 if S=nil
// rax=s,ecx=32-bit of s
pxor xmm0, xmm0 // set to zero
and ecx, 15 // lower 4 bits indicate misalignment
and rax, -16 // align pointer by 16
// will never read outside a memory page boundary, so won't trigger GPF
movaps xmm1, [rax] // read from nearest preceding boundary
pcmpeqb xmm1, xmm0 // compare 16 bytes with zero
pmovmskb edx, xmm1 // get one bit for each byte result
shr edx, cl // shift out false bits
shl edx, cl // shift back again
bsf edx, edx // find first 1-bit
jnz @L2 // found
// Main loop, search 16 bytes at a time
{$ifdef FPC} align 16 {$else} .align 16 {$endif}
@L1: add rax, 10H // increment pointer by 16
movaps xmm1, [rax] // read 16 bytes aligned
pcmpeqb xmm1, xmm0 // compare 16 bytes with zero
pmovmskb edx, xmm1 // get one bit for each byte result
bsf edx, edx // find first 1-bit
// (moving the bsf out of the loop and using test here would be faster
// for long strings on old processors, but we are assuming that most
// strings are short, and newer processors have higher priority)
jz @L1 // loop if not found
@L2: // Zero-byte found. Compute string length
{$ifdef win64}
sub rax, r8 // subtract start address
{$else}
sub rax, rdi
{$endif}
add rax, rdx // add byte index
@null:
end;
{$endif CPU64}
procedure crcblockssse42(crc128, data128: PBlock128; count: integer);
{$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; asm {$else}
asm .noframe {$endif FPC}
test count, count
jle @z
mov rax, data128
{$ifdef win64}
mov rdx, rcx
mov ecx, r8d
{$else}
mov ecx, edx
mov rdx, rdi
{$endif win64}
mov r8d, dword ptr [rdx] // we can't use qword ptr here
mov r9d, dword ptr [rdx + 4]
mov r10d, dword ptr [rdx + 8]
mov r11d, dword ptr [rdx + 12]
{$ifdef FPC} align 16 {$else} .align 16 {$endif}
@s: crc32 r8d, dword ptr [rax]
crc32 r9d, dword ptr [rax + 4]
crc32 r10d, dword ptr [rax + 8]
crc32 r11d, dword ptr [rax + 12]
add rax, 16
dec ecx
jnz @s
mov dword ptr [rdx], r8d
mov dword ptr [rdx + 4], r9d
mov dword ptr [rdx + 8], r10d
mov dword ptr [rdx + 12], r11d
@z:
end;
{$else} {$ifdef FPC} nostackframe; assembler; {$endif}
asm // eax=crc128 edx=data128 ecx=count
push ebx
push esi
push edi
push ebp
test count, count
jle @z
mov ebp, count
mov esi, crc128
mov edi, data128
mov eax, dword ptr[esi]
mov ebx, dword ptr[esi + 4]
mov ecx, dword ptr[esi + 8]
mov edx, dword ptr[esi + 12]
{$ifdef FPC_X86ASM} align 8
@s: crc32 eax, dword ptr[edi]
crc32 ebx, dword ptr[edi + 4]
crc32 ecx, dword ptr[edi + 8]
crc32 edx, dword ptr[edi + 12]
{$else}@s:db $F2, $0F, $38, $F1, $07
db $F2, $0F, $38, $F1, $5F, $04
db $F2, $0F, $38, $F1, $4F, $08
db $F2, $0F, $38, $F1, $57, $0C
{$endif} add edi, 16
dec ebp
jnz @s
mov dword ptr[esi], eax
mov dword ptr[esi + 4], ebx
mov dword ptr[esi + 8], ecx
mov dword ptr[esi + 12], edx
@z: pop ebp
pop edi
pop esi
pop ebx
end;
{$endif CPUX64}
{$endif CPUINTEL}
procedure crcblocksfast(crc128, data128: PBlock128; count: integer);
{$ifdef PUREPASCAL} // efficient registers use on 64-bit, ARM or PIC
var c: cardinal;
tab: PCrc32tab;
begin
tab := @crc32ctab;
if count>0 then
repeat
c := crc128^[0] xor data128^[0];
crc128^[0] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)]
xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)];
c := crc128^[1] xor data128^[1];
crc128^[1] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)]
xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)];
c := crc128^[2] xor data128^[2];
crc128^[2] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)]
xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)];
c := crc128^[3] xor data128^[3];
crc128^[3] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)]
xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)];
inc(data128);
dec(count);
until count=0;
end;
{$else} // call optimized x86 asm within the loop
begin
while count>0 do begin
crcblockNoSSE42(crc128,data128);
inc(data128);
dec(count);
end;
end;
{$endif PUREPASCAL}
{$ifdef CPUINTEL}
function crc32cBy4SSE42(crc, value: cardinal): cardinal;
{$ifdef CPU64} {$ifdef FPC}nostackframe; assembler; asm {$else}
asm .noframe {$endif FPC}
mov eax, crc
crc32 eax, value
end;
{$else} {$ifdef FPC}nostackframe; assembler;{$endif}
asm // eax=crc, edx=value
{$ifdef FPC_X86ASM}
crc32 eax, edx
{$else}
db $F2, $0F, $38, $F1, $C2
{$endif}
end;
{$endif CPU64}
procedure crcblockSSE42(crc128, data128: PBlock128);
{$ifdef CPU64} {$ifdef FPC}nostackframe; assembler; asm {$else}
asm .noframe // rcx=crc128, rdx=data128 (Linux: rdi,rsi)
{$endif FPC}
mov eax, dword ptr[crc128] // we can't use two qword ptr here
mov r8d, dword ptr[crc128 + 4]
mov r9d, dword ptr[crc128 + 8]
mov r10d, dword ptr[crc128 + 12]
crc32 eax, dword ptr[data128]
crc32 r8d, dword ptr[data128 + 4]
crc32 r9d, dword ptr[data128 + 8]
crc32 r10d, dword ptr[data128 + 12]
mov dword ptr[crc128], eax
mov dword ptr[crc128 + 4], r8d
mov dword ptr[crc128 + 8], r9d
mov dword ptr[crc128 + 12], r10d
end;
{$else} {$ifdef FPC}nostackframe; assembler;{$endif}
asm // eax=crc128, edx=data128
mov ecx, eax
{$ifdef FPC_X86ASM}
mov eax, dword ptr[ecx]
crc32 eax, dword ptr[edx]
mov dword ptr[ecx], eax
mov eax, dword ptr[ecx + 4]
crc32 eax, dword ptr[edx + 4]
mov dword ptr[ecx + 4], eax
mov eax, dword ptr[ecx + 8]
crc32 eax, dword ptr[edx + 8]
mov dword ptr[ecx + 8], eax
mov eax, dword ptr[ecx + 12]
crc32 eax, dword ptr[edx + 12]
mov dword ptr[ecx + 12], eax
{$else}
mov eax, dword ptr[ecx]
db $F2, $0F, $38, $F1, $02
mov dword ptr[ecx], eax
mov eax, dword ptr[ecx + 4]
db $F2, $0F, $38, $F1, $42, $04
mov dword ptr[ecx + 4], eax
mov eax, dword ptr[ecx + 8]
db $F2, $0F, $38, $F1, $42, $08
mov dword ptr[ecx + 8], eax
mov eax, dword ptr[ecx + 12]
db $F2, $0F, $38, $F1, $42, $0C
mov dword ptr[ecx + 12], eax
{$endif FPC_OR_UNICODE}
end;
{$endif CPU64}
{$endif CPUINTEL}
function crc32cBy4fast(crc, value: cardinal): cardinal;
var tab: PCrc32tab;
begin
tab := @crc32ctab;
result := crc xor value;
result := tab[3,ToByte(result)] xor
tab[2,ToByte(result shr 8)] xor
tab[1,ToByte(result shr 16)] xor
tab[0,ToByte(result shr 24)];
end;
function crc32cinlined(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
{$ifdef HASINLINE}
var tab: PCrc32tab;
begin
result := not crc;
if len>0 then begin
tab := @crc32ctab;
repeat
result := tab[0,ToByte(result) xor ord(buf^)] xor (result shr 8);
inc(buf);
dec(len);
until len=0;
end;
result := not result;
end;
{$else}
begin
result := crc32c(crc,buf,len);
end;
{$endif}
{$ifdef CPUX86}
procedure GetCPUID(Param: Cardinal; var Registers: TRegisters);
{$ifdef FPC}nostackframe; assembler;{$endif}
asm
push esi
push edi
mov esi, edx
mov edi, eax
pushfd
pop eax
mov edx, eax
xor eax, $200000
push eax
popfd
pushfd
pop eax
xor eax, edx
jz @nocpuid
push ebx
mov eax, edi
xor ecx, ecx
{$ifdef DELPHI5OROLDER}
db $0f, $a2
{$else}
cpuid
{$endif}
mov TRegisters(esi).&eax, eax
mov TRegisters(esi).&ebx, ebx
mov TRegisters(esi).&ecx, ecx
mov TRegisters(esi).&edx, edx
pop ebx
@nocpuid:
pop edi
pop esi
end;
function crc32csse42(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
{$ifdef FPC}nostackframe; assembler;{$endif}
asm // eax=crc, edx=buf, ecx=len
not eax
test ecx, ecx
jz @0
test edx, edx
jz @0
jmp @align
db $8D, $0B4, $26, $00, $00, $00, $00 // manual @by8 align 16
@a: {$ifdef FPC_X86ASM}
crc32 eax, byte ptr[edx]
{$else}
db $F2, $0F, $38, $F0, $02
{$endif}
inc edx
dec ecx
jz @0
@align: test dl, 3
jnz @a
push ecx
shr ecx, 3
jnz @by8
@rem: pop ecx
test cl, 4
jz @4
{$ifdef FPC_X86ASM}
crc32 eax, dword ptr[edx]
{$else}
db $F2, $0F, $38, $F1, $02
{$endif}
add edx, 4
@4: test cl, 2
jz @2
{$ifdef FPC_X86ASM}
crc32 eax, word ptr[edx]
{$else}
db $66, $F2, $0F, $38, $F1, $02
{$endif}
add edx, 2
@2: test cl, 1
jz @0
{$ifdef FPC_X86ASM}
crc32 eax, byte ptr[edx]
{$else}
db $F2, $0F, $38, $F0, $02
{$endif}
@0: not eax
ret
@by8: {$ifdef FPC_X86ASM}
crc32 eax, dword ptr[edx]
crc32 eax, dword ptr[edx + 4]
{$else}
db $F2, $0F, $38, $F1, $02
db $F2, $0F, $38, $F1, $42, $04
{$endif}
add edx, 8
dec ecx
jnz @by8
jmp @rem
end;
{$endif CPUX86}
function crc32cUTF8ToHex(const str: RawUTF8): RawUTF8;
begin
result := CardinalToHex(crc32c(0,pointer(str),length(str)));
end;
function crc64c(buf: PAnsiChar; len: cardinal): Int64;
var hilo: Int64Rec absolute result;
begin
hilo.Lo := crc32c(0,buf,len);
hilo.Hi := crc32c(hilo.Lo,buf,len);
end;
function crc63c(buf: PAnsiChar; len: cardinal): Int64;
var hilo: Int64Rec absolute result;
begin
hilo.Lo := crc32c(0,buf,len);
hilo.Hi := crc32c(hilo.Lo,buf,len) and $7fffffff;
end;
procedure crc128c(buf: PAnsiChar; len: cardinal; out crc: THash128);
var h: THash128Rec absolute crc;
h1,h2: cardinal;
begin // see https://goo.gl/Pls5wi
h1 := crc32c(0,buf,len);
h2 := crc32c(h1,buf,len);
h.i0 := h1; inc(h1,h2);
h.i1 := h1; inc(h1,h2);
h.i2 := h1; inc(h1,h2);
h.i3 := h1;
end;
function IsZero(const dig: THash128): boolean;
var a: TPtrIntArray absolute dig;
begin
result := a[0] or a[1] {$ifndef CPU64}or a[2] or a[3]{$endif} = 0;
end;
function IsEqual(const A,B: THash128): boolean;
var a_: TPtrIntArray absolute A;
b_: TPtrIntArray absolute B;
begin // uses anti-forensic time constant "xor/or" pattern
result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1])
{$ifndef CPU64} or (a_[2] xor b_[2]) or (a_[3] xor b_[3]){$endif})=0;
end;
procedure FillZero(out dig: THash128);
var d: TInt64Array absolute dig;
begin
d[0] := 0;
d[1] := 0;
end;
function Hash128Index(P: PHash128Rec; Count: integer; h: PHash128Rec): integer;
{$ifdef CPU64}
var _0, _1: PtrInt;
begin
if P<>nil then begin
_0 := h^.Lo;
_1 := h^.Hi;
for result := 0 to Count-1 do
if (P^.Lo=_0) and (P^.Hi=_1) then
exit else
inc(P);
end;
result := -1; // not found
end;
{$else}
begin // fast O(n) brute force search
if P<>nil then
for result := 0 to Count-1 do
if (P^.i0=h^.i0) and (P^.i1=h^.i1) and (P^.i2=h^.i2) and (P^.i3=h^.i3) then
exit else
inc(P);
result := -1; // not found
end;
{$endif CPU64}
function IP4Text(ip4: cardinal): shortstring;
var b: array[0..3] of byte absolute ip4;
begin
if ip4=0 then
result := '' else
FormatShort('%.%.%.%',[b[0],b[1],b[2],b[3]],result);
end;
procedure IP6Text(ip6: PHash128; result: PShortString);
var i: integer;
p: PByte;
{$ifdef PUREPASCAL}tab: ^TByteToWord;{$endif}
begin
if IsZero(ip6^) then
result^ := '' else begin
result^[0] := AnsiChar(39);
p := @result^[1];
{$ifdef PUREPASCAL}tab := @TwoDigitsHexWBLower;{$endif}
for i := 0 to 7 do begin
PWord(p)^ := {$ifdef PUREPASCAL}tab{$else}TwoDigitsHexWBLower{$endif}[ip6^[0]]; inc(p,2);
PWord(p)^ := {$ifdef PUREPASCAL}tab{$else}TwoDigitsHexWBLower{$endif}[ip6^[1]]; inc(p,2);
inc(PWord(ip6));
p^ := ord(':'); inc(p);
end;
end;
end;
function IP6Text(ip6: PHash128): shortstring;
begin
IP6Text(ip6, @result);
end;
function IsZero(const dig: THash160): boolean;
var a: TIntegerArray absolute dig;
begin
result := a[0] or a[1] or a[2] or a[3] or a[4] = 0;
end;
function IsEqual(const A,B: THash160): boolean;
var a_: TIntegerArray absolute A;
b_: TIntegerArray absolute B;
begin // uses anti-forensic time constant "xor/or" pattern
result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or (a_[2] xor b_[2]) or
(a_[3] xor b_[3]) or (a_[4] xor b_[4]))=0;
end;
procedure FillZero(out dig: THash160);
begin
PInt64Array(@dig)^[0] := 0;
PInt64Array(@dig)^[1] := 0;
PIntegerArray(@dig)^[4] := 0;
end;
procedure crc256c(buf: PAnsiChar; len: cardinal; out crc: THash256);
var h: THash256Rec absolute crc;
h1,h2: cardinal;
begin // see https://goo.gl/Pls5wi
h1 := crc32c(0,buf,len);
h2 := crc32c(h1,buf,len);
h.i0 := h1; inc(h1,h2);
h.i1 := h1; inc(h1,h2);
h.i2 := h1; inc(h1,h2);
h.i3 := h1; inc(h1,h2);
h.i4 := h1; inc(h1,h2);
h.i5 := h1; inc(h1,h2);
h.i6 := h1; inc(h1,h2);
h.i7 := h1;
end;
function IsZero(const dig: THash256): boolean;
var a: TPtrIntArray absolute dig;
begin
result := a[0] or a[1] or a[2] or a[3]
{$ifndef CPU64} or a[4] or a[5] or a[6] or a[7]{$endif} = 0;
end;
function IsEqual(const A,B: THash256): boolean;
var a_: TPtrIntArray absolute A;
b_: TPtrIntArray absolute B;
begin // uses anti-forensic time constant "xor/or" pattern
result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or
(a_[2] xor b_[2]) or (a_[3] xor b_[3])
{$ifndef CPU64} or (a_[4] xor b_[4]) or (a_[5] xor b_[5])
or (a_[6] xor b_[6]) or (a_[7] xor b_[7]) {$endif})=0;
end;
function Hash256Index(P: PHash256Rec; Count: integer; h: PHash256Rec): integer;
{$ifdef CPU64}
var _0, _1: PtrInt;
begin // fast O(n) brute force search
if P<>nil then begin
_0 := h^.d0;
_1 := h^.d1;
for result := 0 to Count-1 do
if (P^.d0=_0) and (P^.d1=_1) and (P^.d2=h^.d2) and (P^.d3=h^.d3) then
exit else
inc(P);
end;
result := -1; // not found
end;
{$else}
begin
if P<>nil then
for result := 0 to Count-1 do
if (P^.i0=h^.i0) and (P^.i1=h^.i1) and (P^.i2=h^.i2) and (P^.i3=h^.i3) and
(P^.i4=h^.i4) and (P^.i5=h^.i5) and (P^.i6=h^.i6) and (P^.i7=h^.i7) then
exit else
inc(P);
result := -1; // not found
end;
{$endif CPU64}
procedure FillZero(out dig: THash256);
var d: TInt64Array absolute dig;
begin
d[0] := 0;
d[1] := 0;
d[2] := 0;
d[3] := 0;
end;
function IsZero(const dig: THash384): boolean;
var a: TPtrIntArray absolute dig;
begin
result := a[0] or a[1] or a[2] or a[3] or a[4] or a[5]
{$ifndef CPU64} or a[6] or a[7] or a[8] or a[9] or a[10] or a[11] {$endif} = 0;
end;
function IsEqual(const A,B: THash384): boolean;
var a_: TPtrIntArray absolute A;
b_: TPtrIntArray absolute B;
begin // uses anti-forensic time constant "xor/or" pattern
result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or
(a_[2] xor b_[2]) or (a_[3] xor b_[3]) or
(a_[4] xor b_[4]) or (a_[5] xor b_[5])
{$ifndef CPU64} or (a_[6] xor b_[6]) or (a_[7] xor b_[7])
or (a_[8] xor b_[8]) or (a_[9] xor b_[9])
or (a_[10] xor b_[10]) or (a_[11] xor b_[11]) {$endif})=0;
end;
procedure FillZero(out dig: THash384);
var d: TInt64Array absolute dig;
begin
d[0] := 0;
d[1] := 0;
d[2] := 0;
d[3] := 0;
d[4] := 0;
d[5] := 0;
end;
function IsZero(const dig: THash512): boolean;
var a: TPtrIntArray absolute dig;
begin
result := a[0] or a[1] or a[2] or a[3] or a[4] or a[5] or a[6] or a[7] {$ifndef CPU64}
or a[8] or a[9] or a[10] or a[11] or a[12] or a[13] or a[14] or a[15] {$endif} = 0;
end;
function IsEqual(const A,B: THash512): boolean;
var a_: TPtrIntArray absolute A;
b_: TPtrIntArray absolute B;
begin // uses anti-forensic time constant "xor/or" pattern
result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or
(a_[2] xor b_[2]) or (a_[3] xor b_[3]) or
(a_[4] xor b_[4]) or (a_[5] xor b_[5]) or
(a_[6] xor b_[6]) or (a_[7] xor b_[7])
{$ifndef CPU64} or (a_[8] xor b_[8]) or (a_[9] xor b_[9])
or (a_[10] xor b_[10]) or (a_[11] xor b_[11])
or (a_[12] xor b_[12]) or (a_[13] xor b_[13])
or (a_[14] xor b_[14]) or (a_[15] xor b_[15]) {$endif})=0;
end;
procedure FillZero(out dig: THash512);
var d: TInt64Array absolute dig;
begin
d[0] := 0;
d[1] := 0;
d[2] := 0;
d[3] := 0;
d[4] := 0;
d[5] := 0;
d[6] := 0;
d[7] := 0;
end;
procedure crc512c(buf: PAnsiChar; len: cardinal; out crc: THash512);
var h: THash512Rec absolute crc;
h1,h2: cardinal;
begin // see https://goo.gl/Pls5wi
h1 := crc32c(0,buf,len);
h2 := crc32c(h1,buf,len);
h.i0 := h1; inc(h1,h2);
h.i1 := h1; inc(h1,h2);
h.i2 := h1; inc(h1,h2);
h.i3 := h1; inc(h1,h2);
h.i4 := h1; inc(h1,h2);
h.i5 := h1; inc(h1,h2);
h.i6 := h1; inc(h1,h2);
h.i7 := h1; inc(h1,h2);
h.i8 := h1; inc(h1,h2);
h.i9 := h1; inc(h1,h2);
h.i10 := h1; inc(h1,h2);
h.i11 := h1; inc(h1,h2);
h.i12 := h1; inc(h1,h2);
h.i13 := h1; inc(h1,h2);
h.i14 := h1; inc(h1,h2);
h.i15 := h1;
end;
procedure FillZero(var secret: RawByteString);
begin
if secret<>'' then
with PStrRec(Pointer(PtrInt(secret)-STRRECSIZE))^ do
if refCnt=1 then // avoid GPF if const
FillCharFast(pointer(secret)^,length,0);
end;
procedure FillZero(var secret: RawUTF8);
begin
if secret<>'' then
with PStrRec(Pointer(PtrInt(secret)-STRRECSIZE))^ do
if refCnt=1 then // avoid GPF if const
FillCharFast(pointer(secret)^,length,0);
end;
procedure mul64x64(const left, right: QWord; out product: THash128Rec);
{$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; asm {$else}
asm .noframe // rcx/rdi=left, rdx/rsi=right r8/rdx=product
{$endif}{$ifdef WIN64}
mov rax, rcx
mul rdx // uses built-in 64-bit -> 128-bit multiplication
{$else} mov r8, rdx
mov rax, rdi
mul rsi
{$endif}mov qword ptr [r8], rax
mov qword ptr [r8+8], rdx
end;
{$else}
{$ifdef CPUX86} {$ifdef FPC} nostackframe; assembler; {$endif}
asm // adapted from FPC compiler output, which is much better than Delphi's here
{$ifdef FPC}
push ebp
mov ebp, esp
{$endif FPC}
mov ecx, eax
mov eax, dword ptr [ebp+8H]
mul dword ptr [ebp+10H]
mov dword ptr [ecx], eax
mov dword ptr [ebp-4H], edx
mov eax, dword ptr [ebp+8H]
mul dword ptr [ebp+14H]
add eax, dword ptr [ebp-4H]
adc edx, 0
mov dword ptr [ebp-10H], eax
mov dword ptr [ebp-0CH], edx
mov eax, dword ptr [ebp+0CH]
mul dword ptr [ebp+10H]
add eax, dword ptr [ebp-10H]
adc edx, 0
mov dword ptr [ecx+4H], eax
mov dword ptr [ebp-14H], edx
mov eax, dword ptr [ebp+0CH]
mul dword ptr [ebp+14H]
add eax, dword ptr [ebp-0CH]
adc edx, 0
add eax, dword ptr [ebp-14H]
adc edx, 0
mov dword ptr [ecx+8H], eax
mov dword ptr [ecx+0CH], edx
{$ifdef FPC}
pop ebp
{$endif FPC}
end;
{$else} // CPU-neutral implementation
var l: TQWordRec absolute left;
r: TQWordRec absolute right;
t1,t2,t3: TQWordRec;
begin
t1.V := QWord(l.L)*r.L;
t2.V := QWord(l.H)*r.L+t1.H;
t3.V := QWord(l.L)*r.H+t2.L;
product.H := QWord(l.H)*r.H+t2.H+t3.H;
product.L := t3.V shl 32 or t1.L;
end;
{$endif CPUX86}
{$endif CPUX64}
{$ifndef ABSOLUTEPASCAL}
{$ifdef CPUX64}
const
// non-temporal writes should bypass the cache when the size is bigger than
// half the size of the largest level cache - we assume low 1MB cache here
CPUCACHEX64 = 512*1024;
{
regarding benchmark numbers from TTestLowLevelCommon.CustomRTL
-> FillCharFast/MoveFast are faster, especially for small lengths (strings)
-> Delphi RTL is lower than FPC's, and it doesn't support AVX assembly yet
-> cpuERMS - of little benefit - is disabled, unless WITH_ERMS is defined
http://blog.synopse.info/post/2020/02/17/New-move/fillchar-optimized-sse2/avx-asm-version
}
// these stand-alone functions will use CPUIDX64 to adjust the algorithm
procedure MoveFast(const src; var dst; cnt: PtrInt);
{$ifdef FPC}nostackframe; assembler;
asm {$else} asm .noframe {$endif} // rcx/rdi=src rdx/rsi=dst r8/rdx=cnt
{$ifdef WIN64}
mov rax, r8
{$else}
mov rax, rdx // rax=r8=cnt
mov r8, rdx
{$endif}
lea r10, [rip+@jmptab]
cmp src, dst
je @equal
cmp cnt, 32
ja @lrg // >32 or <0
sub rax, 8
jg @sml // 9..32
jmp qword ptr[r10 + 64 + rax * 8] // 0..8
@equal: ret
{$ifdef FPC} align 8 {$else} .align 8 {$endif}
@jmptab:dq @exit, @01, @02, @03, @04, @05, @06, @07, @08
@sml: mov r8, qword ptr[src + rax] // last 8
mov r9, qword ptr[src] // first 8
cmp al, 8
jle @sml16
mov r10, qword ptr[src + 8] // second 8
cmp al, 16
jle @sml24
mov r11, qword ptr[src + 16] // third 8
mov qword ptr[dst + 16], r11 // third 8
@sml24: mov qword ptr[dst + 8], r10 // second 8
@sml16: mov qword ptr[dst], r9 // first 8
mov qword ptr[dst + rax], r8 // last 8 (may be overlapping)
ret
@02: movzx eax, word ptr[src] // use small size moves as code alignment
mov word ptr[dst], ax
ret
@04: mov eax, [src]
mov dword ptr[dst], eax
ret
@08: mov rax, [src]
mov [dst], rax
@exit: ret
@lrg: jng @exit // cnt < 0
cmp src, dst
ja @lrgfwd
sub dst, rax
cmp src, dst
lea dst, [dst + rax]
ja @lrgbwd
@lrgfwd:{$ifdef WITH_ERMS}
test byte ptr[rip+CPUIDX64], 1 shl cpuERMS
jz @nofwe
cmp rax, 2048
jb @nofwe
cld
@repmov:{$ifdef WIN64}
push rsi
push rdi
mov rsi, src
mov rdi, dst
mov rcx, r8
rep movsb
pop rdi
pop rsi
{$else}
mov rax, dst // dst=rsi and src=rdi -> rax to swap
mov rsi, src
mov rdi, rax
mov rcx, r8
rep movsb
{$endif}
ret
@nofwe: {$endif WITH_ERMS}
mov r9, dst
{$ifdef FPC} // no AVX asm on Delphi :(
cmp rax, 256 // vzeroupper penaly for cnt>255
jb @fsse2
test byte ptr[rip+CPUIDX64], 1 shl cpuAVX
jnz @fwdavx
{$endif FPC}
@fsse2: movups xmm2, oword ptr[src] // first 16
lea src, [src + rax - 16]
lea rax, [rax + dst - 16]
movups xmm1, oword ptr[src] // last 16
mov r10, rax
neg rax
and dst, -16 // 16-byte aligned writes
lea rax, [rax + dst + 16]
cmp r8, CPUCACHEX64
ja @fwdnv // bypass cache for cnt>512KB
{$ifdef FPC} align 16 {$else} .align 16 {$endif}
@fwd: movups xmm0, oword ptr[src + rax] // regular loop
movaps [r10 + rax], xmm0
add rax, 16
jl @fwd
@fwdend:movups [r10], xmm1 // last 16
movups [r9], xmm2 // first 16
ret
{$ifdef FPC} align 16 {$else} .align 16 {$endif}
@fwdnv: movups xmm0, oword ptr[src + rax] // non-temporal loop
movntdq [r10 + rax], xmm0
add rax, 16
jl @fwdnv
sfence
jmp @fwdend
{$ifdef FPC}
@fwdavx:vmovups ymm2, oword ptr[src] // first 32
lea src, [src + rax - 32]
lea rax, [rax + dst - 32]
vmovups ymm1, oword ptr[src] // last 32
mov r10, rax
neg rax
and dst, -32 // 32-byte aligned writes
lea rax, [rax + dst + 32]
cmp r8, CPUCACHEX64
ja @favxn // bypass cache for cnt>512KB
align 16
@favxr: vmovups ymm0, oword ptr[src + rax] // regular loop
vmovaps [r10 + rax], ymm0
add rax, 32
jl @favxr
@favxe: vmovups [r10], ymm1 // last 32
vmovups [r9], ymm2 // first 32
// https://software.intel.com/en-us/articles/avoiding-avx-sse-transition-penalties
vzeroupper
ret
align 16
@favxn: vmovups ymm0, oword ptr[src + rax] // non-temporal loop
vmovntps [r10 + rax], ymm0
add rax, 32
jl @favxn
sfence
jmp @favxe
{$endif FPC}
@lrgbwd:{$ifdef WITH_ERMS} // backward move
test byte ptr[rip+CPUIDX64], 1 shl cpuERMS
jz @nobwe
cmp rax, 2048
jb @nobwe
std
lea src, [src + rax - 1]
lea dst, [dst + rax - 1]
jmp @repmov
@nobwe: {$endif WITH_ERMS}
{$ifdef FPC}
cmp rax, 256
jb @bsse2
test byte ptr[rip+CPUIDX64], 1 shl cpuAVX
jnz @bwdavx
{$endif FPC}
@bsse2: sub rax, 16
mov r9, rax
movups xmm2, oword ptr[src + rax] // last 16
movups xmm1, oword ptr[src] // first 16
add rax, dst
and rax, -16 // 16-byte aligned writes
sub rax, dst
cmp r8, CPUCACHEX64
ja @bwdnv // bypass cache for cnt>512KB
{$ifdef FPC} align 16 {$else} .align 16 {$endif}
@bwd: movups xmm0, oword ptr[src + rax] // regular loop
movaps oword ptr[dst + rax], xmm0
sub rax, 16
jg @bwd
@bwdend:movups oword ptr[dst], xmm1 // first 16
movups oword ptr[dst + r9], xmm2 // last 16
ret
@01: mov al, byte ptr[src]
mov byte ptr[dst], al
ret
{$ifdef FPC} align 16 {$else} .align 16 {$endif}
@bwdnv: movups xmm0, oword ptr[src + rax] // non-temporal loop
movntdq oword ptr[dst + rax], xmm0
sub rax, 16
jg @bwdnv
sfence
jmp @bwdend
{$ifdef FPC}
@bwdavx:sub rax, 32
mov r9, rax
vmovups ymm2, oword ptr[src + rax] // last 32
vmovups ymm1, oword ptr[src] // first 32
add rax, dst
and rax, -32 // 32-byte aligned writes
sub rax, dst
cmp r8, CPUCACHEX64
ja @bavxn // bypass cache for cnt>512KB
align 16
@bavxr: vmovups ymm0, oword ptr[src + rax] // regular loop
vmovaps oword ptr[dst + rax], ymm0
sub rax, 32
jg @bavxr
@bavxe: vmovups oword ptr[dst], ymm1 // first 32
vmovups oword ptr[dst + r9], ymm2 // last 32
vzeroupper
ret
align 16
@bavxn: vmovups ymm0, oword ptr[src + rax] // non-temporal loop
vmovntps oword ptr[dst + rax], ymm0
sub rax, 32
jg @bavxn
sfence
jmp @bavxe
{$endif FPC}
@03: movzx eax, word ptr[src]
mov cl, byte ptr[src + 2]
mov word ptr[dst], ax
mov byte ptr[dst + 2], cl
ret
@05: mov eax, dword ptr[src]
mov cl, byte ptr[src + 4]
mov dword ptr[dst], eax
mov byte ptr[dst + 4], cl
ret
@06: mov eax, dword ptr[src]
mov cx, word ptr[src + 4]
mov dword ptr[dst], eax
mov word ptr[dst + 4], cx
ret
@07: mov r8d, dword ptr[src] // faster with no overlapping
mov ax, word ptr[src + 4]
mov cl, byte ptr[src + 6]
mov dword ptr[dst], r8d
mov word ptr[dst + 4], ax
mov byte ptr[dst + 6], cl
end;
procedure FillCharFast(var dst; cnt: PtrInt; value: byte);
{$ifdef FPC}nostackframe; assembler;
asm {$else} asm .noframe {$endif} // rcx/rdi=dst rdx/rsi=cnt r8b/dl=val
mov r9, $0101010101010101
lea r10, [rip+@jmptab]
{$ifdef WIN64}
movzx eax, r8b
{$else}
movzx eax, dl
mov rdx, rsi // rdx=cnt
{$endif}
imul rax, r9 // broadcast value into all bytes of rax (in 1 cycle)
cmp cnt, 32
ja @abv32 // >32 or <0
sub rdx, 8
jg @sml // small 9..32
jmp qword ptr[r10 + 64 + rdx*8] // tiny 0..8 bytes
{$ifdef FPC} align 8 {$else} .align 8 {$endif}
@jmptab:dq @00, @01, @02, @03, @04, @05, @06, @07, @08
@sml: cmp dl, 8 // 9..32 bytes
jle @sml16
cmp dl, 16
jle @sml24
mov qword ptr[dst+16], rax
@sml24: mov qword ptr[dst+8], rax
@sml16: mov qword ptr[dst+rdx], rax // last 8 (may be overlapping)
@08: mov qword ptr[dst], rax
@00: ret
@07: mov dword ptr[dst+3], eax
@03: mov word ptr[dst+1], ax
@01: mov byte ptr[dst], al
ret
@06: mov dword ptr[dst+2], eax
@02: mov word ptr[dst], ax
ret
@05: mov byte ptr[dst+4], al
@04: mov dword ptr[dst], eax
ret
{$ifdef FPC} align 8{$else} .align 8{$endif}
@abv32: jng @00 // < 0
movd xmm0, eax
lea r8, [dst+cnt] // r8 point to end
pshufd xmm0, xmm0, 0 // broadcast value into all bytes of xmm0
mov r10, rdx // save rdx=cnt
{$ifdef FPC} // Delphi doesn't support avx, and erms is slower
cmp rdx, 256
jae @abv256 // try erms or avx if cnt>255 (vzeroupper penalty)
{$endif FPC}
@sse2: movups oword ptr[dst], xmm0 // first unaligned 16 bytes
lea rdx, [dst+rdx-1]
and rdx, -16
add dst, 16
and dst, -16 // dst is 16-bytes aligned
sub dst, rdx
jnb @last
cmp r10, CPUCACHEX64
ja @nv // bypass cache for cnt>512KB
{$ifdef FPC} align 16 {$else} .align 16 {$endif}
@reg: movaps oword ptr[rdx+dst], xmm0 // regular loop
add dst, 16
jnz @reg
@last: movups oword ptr[r8-16], xmm0 // last unaligned 16 bytes
ret
{$ifdef FPC} align 16 {$else} .align 16 {$endif}
@nv: movntdq [rdx+dst], xmm0 // non-temporal loop
add dst, 16
jnz @nv
sfence
movups oword ptr[r8-16], xmm0
ret
{$ifdef FPC}
@abv256:{$ifdef WITH_ERMS}
mov r9b, byte ptr[rip+CPUIDX64]
test r9b, 1 shl cpuERMS
jz @noerms
cmp rdx, 2048 // ERMS is worth it for cnt>2KB
jb @noerms
cmp rdx, CPUCACHEX64 // non-temporal moves are still faster
jae @noerms
cld
{$ifdef WIN64}
mov r8, rdi
mov rdi, dst
mov rcx, cnt
rep stosb
mov rdi, r8
{$else} mov rcx, cnt
rep stosb
{$endif}ret
@noerms:test r9b, 1 shl cpuAVX
{$else} test byte ptr[rip+CPUIDX64], 1 shl cpuAVX
{$endif WITH_ERMS}
jz @sse2
movups oword ptr[dst], xmm0 // first unaligned 1..16 bytes
add dst, 16
and dst, -16
movaps oword ptr[dst], xmm0 // aligned 17..32 bytes
vinsertf128 ymm0,ymm0,xmm0,1
add dst, 16
and dst, -32 // dst is 32-bytes aligned
mov rdx, r8
and rdx, -32
sub dst, rdx
cmp r10, CPUCACHEX64
ja @avxnv
align 16
@avxreg:vmovaps ymmword ptr[rdx+dst], ymm0 // regular loop
add dst, 32
jnz @avxreg
@avxok: vmovups oword ptr[r8-32], ymm0 // last unaligned 32 bytes
vzeroupper
ret
align 16
@avxnv: vmovntps oword ptr [rdx+dst], ymm0 // non-temporal loop
add dst, 32
jnz @avxnv
sfence
jmp @avxok
{$endif FPC}
end;
{$endif CPUX64}
{$endif ABSOLUTEPASCAL}
procedure SymmetricEncrypt(key: cardinal; var data: RawByteString);
var i,len: integer;
d: PCardinal;
tab: PCrc32tab;
begin
if data='' then
exit; // nothing to cypher
tab := @crc32ctab;
{$ifdef FPC}
UniqueString(data); // @data[1] won't call UniqueString() under FPC :(
{$endif}
d := @data[1];
len := length(data);
key := key xor cardinal(len);
for i := 0 to (len shr 2)-1 do begin
key := key xor tab[0,(cardinal(i) xor key)and 1023];
d^ := d^ xor key;
inc(d);
end;
for i := 0 to (len and 3)-1 do
PByteArray(d)^[i] := PByteArray(d)^[i] xor key xor tab[0,17 shl i];
end;
function UnixTimeToDateTime(const UnixTime: TUnixTime): TDateTime;
begin
result := UnixTime / SecsPerDay + UnixDateDelta;
end;
function DateTimeToUnixTime(const AValue: TDateTime): TUnixTime;
begin
result := Round((AValue - UnixDateDelta) * SecsPerDay);
end;
const
UnixFileTimeDelta = 116444736000000000; // from year 1601 to 1970
DateFileTimeDelta = 94353120000000000; // from year 1601 to 1899
{$ifdef MSWINDOWS}
function FileTimeToUnixTime(const FT: TFileTime): TUnixTime;
{$ifdef CPU64}var nano100: Int64;{$endif}
begin
{$ifdef CPU64}
FileTimeToInt64(ft,nano100);
result := (nano100-UnixFileTimeDelta) div 10000000;
{$else} // use PInt64 to avoid URW699 with Delphi 6 / Kylix
result := (PInt64(@ft)^-UnixFileTimeDelta) div 10000000;
{$endif}
end;
function FileTimeToUnixMSTime(const FT: TFileTime): TUnixMSTime;
{$ifdef CPU64}var nano100: Int64;{$endif}
begin
{$ifdef CPU64}
FileTimeToInt64(ft,nano100);
result := (nano100-UnixFileTimeDelta) div 10000;
{$else} // use PInt64 to avoid URW699 with Delphi 6 / Kylix
result := (PInt64(@ft)^-UnixFileTimeDelta) div 10000;
{$endif}
end;
function UnixTimeUTC: TUnixTime;
var ft: TFileTime;
begin
GetSystemTimeAsFileTime(ft); // very fast, with 100 ns unit
result := FileTimeToUnixTime(ft);
end;
function UnixMSTimeUTC: TUnixMSTime;
var ft: TFileTime;
begin
GetSystemTimePreciseAsFileTime(ft); // slower, but try to achieve ms resolution
result := FileTimeToUnixMSTime(ft);
end;
function UnixMSTimeUTCFast: TUnixMSTime;
var ft: TFileTime;
begin
GetSystemTimeAsFileTime(ft); // faster, but with HW interupt resolution
result := FileTimeToUnixMSTime(ft);
end;
{$else MSWINDOWS}
function UnixTimeUTC: TUnixTime;
begin
result := GetUnixUTC; // direct retrieval from UNIX API
end;
function UnixMSTimeUTC: TUnixMSTime;
begin
result := GetUnixMSUTC; // direct retrieval from UNIX API
end;
function UnixMSTimeUTCFast: TUnixMSTime;
begin
result := GetUnixMSUTC; // direct retrieval from UNIX API
end;
{$endif MSWINDOWS}
function DaysToIso8601(Days: cardinal; Expanded: boolean): RawUTF8;
var Y,M: cardinal;
begin
Y := 0;
while Days>365 do begin
dec(Days,366);
inc(Y);
end;
M := 0;
if Days>31 then begin
inc(M);
while Days>MonthDays[false][M] do begin
dec(Days,MonthDays[false][M]);
inc(M);
end;
end;
result := DateToIso8601(Y,M,Days,Expanded);
end;
function UnixTimeToString(const UnixTime: TUnixTime; Expanded: boolean;
FirstTimeChar: AnsiChar): RawUTF8;
begin // inlined UnixTimeToDateTime
result := DateTimeToIso8601(UnixTime/SecsPerDay+UnixDateDelta,Expanded,
FirstTimeChar,false);
end;
function DateTimeToFileShort(const DateTime: TDateTime): TShort16;
begin
DateTimeToFileShort(DateTime,result);
end;
procedure DateTimeToFileShort(const DateTime: TDateTime; out result: TShort16);
var T: TSynSystemTime;
tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif};
begin // use 'YYMMDDHHMMSS' format
if DateTime<=0 then begin
PWord(@result[0])^ := 1+ord('0') shl 8;
exit;
end;
T.FromDate(DateTime);
if T.Year > 1999 then
if T.Year < 2100 then
dec(T.Year,2000) else
T.Year := 99 else
T.Year := 0;
T.FromTime(DateTime);
{$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif}
result[0] := #12;
PWord(@result[1])^ := tab[T.Year];
PWord(@result[3])^ := tab[T.Month];
PWord(@result[5])^ := tab[T.Day];
PWord(@result[7])^ := tab[T.Hour];
PWord(@result[9])^ := tab[T.Minute];
PWord(@result[11])^ := tab[T.Second];
end;
procedure UnixTimeToFileShort(const UnixTime: TUnixTime; out result: TShort16);
begin // use 'YYMMDDHHMMSS' format
if UnixTime<=0 then
PWord(@result[0])^ := 1+ord('0') shl 8 else
DateTimeToFileShort(UnixTime/SecsPerDay+UnixDateDelta, result);
end;
function UnixTimeToFileShort(const UnixTime: TUnixTime): TShort16;
begin
UnixTimeToFileShort(UnixTime, result);
end;
function UnixMSTimeToFileShort(const UnixMSTime: TUnixMSTime): TShort16;
begin
UnixTimeToFileShort(UnixMSTime div MSecsPerSec, result);
end;
function UnixTimePeriodToString(const UnixTime: TUnixTime; FirstTimeChar: AnsiChar): RawUTF8;
begin
if UnixTime<SecsPerDay then
result := TimeToIso8601(UnixTime/SecsPerDay,true,FirstTimeChar) else
result := DaysToIso8601(UnixTime div SecsPerDay,true);
end;
function UnixMSTimeToDateTime(const UnixMSTime: TUnixMSTime): TDateTime;
begin
result := UnixMSTime/MSecsPerDay + UnixDateDelta;
end;
function UnixMSTimePeriodToString(const UnixMSTime: TUnixMSTime; FirstTimeChar: AnsiChar): RawUTF8;
begin
if UnixMSTime<MSecsPerDay then
result := TimeToIso8601(UnixMSTime/MSecsPerDay,true,FirstTimeChar,UnixMSTime<1000) else
result := DaysToIso8601(UnixMSTime div MSecsPerDay,true);
end;
function DateTimeToUnixMSTime(const AValue: TDateTime): TUnixMSTime;
begin
if AValue=0 then
result := 0 else
result := Round((AValue - UnixDateDelta) * MSecsPerDay);
end;
function UnixMSTimeToString(const UnixMSTime: TUnixMSTime; Expanded: boolean;
FirstTimeChar: AnsiChar; const TZD: RawUTF8): RawUTF8;
begin // inlined UnixMSTimeToDateTime()
if UnixMSTime<=0 then
result := '' else
result := DateTimeMSToString(UnixMSTime/MSecsPerDay+UnixDateDelta,Expanded,
FirstTimeChar,TZD);
end;
function NowUTC: TDateTime;
{$ifdef MSWINDOWS}
var ft: TFileTime;
{$ifdef CPU64}nano100: Int64; d: double;{$endif}
begin
GetSystemTimeAsFileTime(ft); // very fast, with 100 ns unit and 16ms resolution
{$ifdef CPU64}
FileTimeToInt64(ft,nano100);
// in two explicit steps to circumvent weird precision error on FPC
// having d: double is important here
d := (nano100-DateFileTimeDelta) / 10000000;
result := d/SecsPerDay;
{$else} // use PInt64 to avoid URW699 with Delphi 6 / Kylix
dec(PInt64(@ft)^,DateFileTimeDelta);
result := PInt64(@ft)^/(10000000.0*SecsPerDay);
{$endif}
end;
{$else}
begin
result := GetNowUTC; // calls clock_gettime(CLOCK_REALTIME_COARSE)
end;
{$endif}
function Iso8601ToDateTimePUTF8Char(P: PUTF8Char; L: integer): TDateTime;
var tmp: TDateTime; // circumvent FPC limitation
begin
Iso8601ToDateTimePUTF8CharVar(P,L,tmp);
result := tmp;
end;
function Iso8601CheckAndDecode(P: PUTF8Char; L: integer; var Value: TDateTime): boolean;
// handle 'YYYY-MM-DDThh:mm:ss[.sss]' or 'YYYY-MM-DD' or 'Thh:mm:ss[.sss]'
begin
if P=nil then
result := false else
if (((L=9)or(L=13)) and (P[0]='T') and (P[3]=':')) or // 'Thh:mm:ss[.sss]'
((L=10) and (P[4]='-') and (P[7]='-')) or // 'YYYY-MM-DD'
(((L=19)or(L=23)) and (P[4]='-') and (P[10]='T')) then begin
Iso8601ToDateTimePUTF8CharVar(P,L,Value);
result := PInt64(@Value)^<>0;
end else
result := false;
end;
function Char2ToByte(P: PUTF8Char; out Value: Cardinal): Boolean;
var B: PtrUInt;
begin
B := ConvertHexToBin[ord(P[0])];
if B<=9 then begin
Value := B;
B := ConvertHexToBin[ord(P[1])];
if B<=9 then begin
Value := Value*10+B;
result := false;
exit;
end;
end;
result := true; // error
end;
function Char3ToWord(P: PUTF8Char; out Value: Cardinal): Boolean;
var B: PtrUInt;
begin
B := ConvertHexToBin[ord(P[0])];
if B<=9 then begin
Value := B;
B := ConvertHexToBin[ord(P[1])];
if B<=9 then begin
Value := Value*10+B;
B := ConvertHexToBin[ord(P[2])];
if B<=9 then begin
Value := Value*10+B;
result := false;
exit;
end;
end;
end;
result := true; // error
end;
function Char4ToWord(P: PUTF8Char; out Value: Cardinal): Boolean;
var B: PtrUInt;
begin
B := ConvertHexToBin[ord(P[0])];
if B<=9 then begin
Value := B;
B := ConvertHexToBin[ord(P[1])];
if B<=9 then begin
Value := Value*10+B;
B := ConvertHexToBin[ord(P[2])];
if B<=9 then begin
Value := Value*10+B;
B := ConvertHexToBin[ord(P[3])];
if B<=9 then begin
Value := Value*10+B;
result := false;
exit;
end;
end;
end;
end;
result := true; // error
end;
procedure Iso8601ToDateTimePUTF8CharVar(P: PUTF8Char; L: integer; var result: TDateTime);
var B: cardinal;
Y,M,D, H,MI,SS,MS: cardinal;
d100: TDiv100Rec;
tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif};
// expect 'YYYYMMDDThhmmss[.sss]' format but handle also 'YYYY-MM-DDThh:mm:ss[.sss]'
begin
unaligned(result) := 0;
if P=nil then
exit;
if L=0 then
L := StrLen(P);
if L<4 then
exit; // we need 'YYYY' at least
if (P[0]='''') and (P[L-1]='''') then begin // unquote input
inc(P);
dec(L, 2);
if L<4 then exit;
end;
if P[0]='T' then begin
dec(P,8);
inc(L,8);
end else begin
{$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64
B := tab[ord(P[0])]; // first digit
if B>9 then exit else Y := B; // fast check '0'..'9'
B := tab[ord(P[1])];
if B>9 then exit else Y := Y*10+B;
B := tab[ord(P[2])];
if B>9 then exit else Y := Y*10+B;
B := tab[ord(P[3])];
if B>9 then exit else Y := Y*10+B;
if P[4] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD
D := 1;
if L>=6 then begin // YYYYMM
M := ord(P[4])*10+ord(P[5])-(48+480);
if (M=0) or (M>12) then exit;
if P[6] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD
if L>=8 then begin // YYYYMMDD
if (L>8) and not(P[8] in [#0,' ','T']) then
exit; // invalid date format
D := ord(P[6])*10+ord(P[7])-(48+480);
if (D=0) or (D>MonthDays[true][M]) then exit; // worse is leap year=true
end;
end else
M := 1;
if M>2 then // inlined EncodeDate(Y,M,D)
dec(M,3) else
if M>0 then begin
inc(M,9);
dec(Y);
end;
if Y>9999 then
exit; // avoid integer overflow e.g. if '0000' is an invalid date
Div100(Y,d100);
unaligned(result) := (146097*d100.d) shr 2 + (1461*d100.m) shr 2 +
(153*M+2) div 5+D;
unaligned(result) := unaligned(result)-693900; // as float: avoid sign issue
if L<15 then
exit; // not enough space to retrieve the time
end;
H := ord(P[9])*10+ord(P[10])-(48+480);
if P[11]=':' then begin inc(P); dec(L); end;// allow hh:mm:ss
MI := ord(P[11])*10+ord(P[12])-(48+480);
if P[13]=':' then begin inc(P); dec(L); end; // allow hh:mm:ss
SS := ord(P[13])*10+ord(P[14])-(48+480);
if (L>16) and (P[15]='.') then begin
// one or more digits representing a decimal fraction of a second
MS := ord(P[16])*100-4800;
if L>17 then MS := MS+ord(P[17])*10-480;
if L>18 then MS := MS+ord(P[18])-48;
if MS>1000 then
MS := 0;
end else
MS := 0;
if (H<24) and (MI<60) and (SS<60) then // inlined EncodeTime()
result := result+(H*(MinsPerHour*SecsPerMin*MSecsPerSec)+
MI*(SecsPerMin*MSecsPerSec)+SS*MSecsPerSec+MS)/MSecsPerDay;
end;
function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer): TDateTime;
begin
Iso8601ToTimePUTF8CharVar(P,L,result);
end;
procedure Iso8601ToTimePUTF8CharVar(P: PUTF8Char; L: integer; var result: TDateTime);
var H,MI,SS,MS: cardinal;
begin
if Iso8601ToTimePUTF8Char(P,L,H,MI,SS,MS) then
result := (H*(MinsPerHour*SecsPerMin*MSecsPerSec)+
MI*(SecsPerMin*MSecsPerSec)+SS*MSecsPerSec+MS)/MSecsPerDay else
result := 0;
end;
function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer; var H,M,S,MS: cardinal): boolean;
begin
result := false; // error
if P=nil then
exit;
if L=0 then
L := StrLen(P);
if L<6 then
exit; // we need 'hhmmss' at least
H := ord(P[0])*10+ord(P[1])-(48+480);
if P[2]=':' then begin inc(P); dec(L); end; // allow hh:mm:ss
M := ord(P[2])*10+ord(P[3])-(48+480);
if P[4]=':' then begin inc(P); dec(L); end; // allow hh:mm:ss
S := ord(P[4])*10+ord(P[5])-(48+480);
if (L>6) and (P[6]='.') then begin
// one or more digits representing a decimal fraction of a second
MS := ord(P[7])*100-4800;
if L>7 then MS := MS+ord(P[8])*10-480;
if L>8 then MS := MS+ord(P[9])-48;
end else
MS := 0;
if (H<24) and (M<60) and (S<60) and (MS<1000) then
result := true;
end;
function Iso8601ToDatePUTF8Char(P: PUTF8Char; L: integer; var Y,M,D: cardinal): boolean;
begin
result := false; // error
if P=nil then
exit;
if L=0 then
L := StrLen(P);
if (L<8) or not (P[0] in ['0'..'9']) or not (P[1] in ['0'..'9']) or
not (P[2] in ['0'..'9']) or not (P[3] in ['0'..'9']) then
exit; // we need 'YYYYMMDD' at least
Y := ord(P[0])*1000+ord(P[1])*100+ord(P[2])*10+ord(P[3])-(48+480+4800+48000);
if (Y<1000) or (Y>2999) then
exit;
if P[4] in ['-','/'] then inc(P); // allow YYYY-MM-DD
M := ord(P[4])*10+ord(P[5])-(48+480);
if (M=0) or (M>12) then
exit;
if P[6] in ['-','/'] then inc(P);
D := ord(P[6])*10+ord(P[7])-(48+480);
if (D<>0) and (D<=MonthDays[true][M]) then
result := true;
end;
function IntervalTextToDateTime(Text: PUTF8Char): TDateTime;
begin
IntervalTextToDateTimeVar(Text,result);
end;
procedure IntervalTextToDateTimeVar(Text: PUTF8Char; var result: TDateTime);
var negative: boolean;
Time: TDateTime;
begin // e.g. IntervalTextToDateTime('+0 06:03:20')
result := 0;
if Text=nil then
exit;
if Text^ in ['+','-'] then begin
negative := (Text^='-');
result := GetNextItemDouble(Text,' ');
end else
negative := false;
Iso8601ToTimePUTF8CharVar(Text,0,Time);
if negative then
result := result-Time else
result := result+Time;
end;
function Iso8601ToDateTime(const S: RawByteString): TDateTime;
begin
result := Iso8601ToDateTimePUTF8Char(pointer(S),length(S));
end;
function TimeLogToDateTime(const Timestamp: TTimeLog): TDateTime;
begin
result := PTimeLogBits(@Timestamp)^.ToDateTime;
end;
function TimeLogToUnixTime(const Timestamp: TTimeLog): TUnixTime;
begin
result := PTimeLogBits(@Timestamp)^.ToUnixTime;
end;
function DateToIso8601PChar(P: PUTF8Char; Expanded: boolean; Y,M,D: PtrUInt): PUTF8Char;
// use 'YYYYMMDD' format if not Expanded, 'YYYY-MM-DD' format if Expanded
var tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif};
begin
{$ifdef CPUX86NOTPIC}
YearToPChar(Y,P);
{$else}
tab := @TwoDigitLookupW;
YearToPChar2(tab,Y,P);
{$endif}
inc(P,4);
if Expanded then begin
P^ := '-';
inc(P);
end;
PWord(P)^ := tab[M];
inc(P,2);
if Expanded then begin
P^ := '-';
inc(P);
end;
PWord(P)^ := tab[D];
result := P+2;
end;
function TimeToIso8601PChar(P: PUTF8Char; Expanded: boolean; H,M,S,MS: PtrUInt;
FirstChar: AnsiChar; WithMS: boolean): PUTF8Char;
var tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif};
begin // use Thhmmss[.sss] format
if FirstChar<>#0 then begin
P^ := FirstChar;
inc(P);
end;
{$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif}
PWord(P)^ := tab[H];
inc(P,2);
if Expanded then begin
P^ := ':';
inc(P);
end;
PWord(P)^ := tab[M];
inc(P,2);
if Expanded then begin
P^ := ':';
inc(P);
end;
PWord(P)^ := tab[S];
inc(P,2);
if WithMS then begin
{$ifdef CPUX86NOTPIC}YearToPChar(MS{$else}YearToPChar2(tab,MS{$endif},P);
P^ := '.'; // override first '0' digit
inc(P,4);
end;
result := P;
end;
function DateToIso8601PChar(Date: TDateTime; P: PUTF8Char; Expanded: boolean): PUTF8Char;
var T: TSynSystemTime;
begin // use YYYYMMDD / YYYY-MM-DD date format
T.FromDate(Date);
result := DateToIso8601PChar(P,Expanded,T.Year,T.Month,T.Day);
end;
function DateToIso8601Text(Date: TDateTime): RawUTF8;
begin // into 'YYYY-MM-DD' date format
if Date=0 then
result := '' else begin
FastSetString(result,nil,10);
DateToIso8601PChar(Date,pointer(result),True);
end;
end;
function TimeToIso8601PChar(Time: TDateTime; P: PUTF8Char; Expanded: boolean;
FirstChar: AnsiChar; WithMS: boolean): PUTF8Char;
var T: TSynSystemTime;
begin
T.FromTime(Time);
result := TimeToIso8601PChar(P,Expanded,T.Hour,T.Minute,T.Second,T.MilliSecond,FirstChar,WithMS);
end;
function DateTimeToIso8601(P: PUTF8Char; D: TDateTime; Expanded: boolean;
FirstChar: AnsiChar; WithMS: boolean; QuotedChar: AnsiChar): integer;
var S: PUTF8Char;
begin
S := P;
if QuotedChar<>#0 then begin
P^ := QuotedChar;
inc(P);
end;
P := DateToIso8601PChar(D,P,Expanded);
P := TimeToIso8601PChar(D,P,Expanded,FirstChar,WithMS);
if QuotedChar<>#0 then begin
P^ := QuotedChar;
inc(P);
end;
result := P-S;
end;
function DateTimeToIso8601(D: TDateTime; Expanded: boolean;
FirstChar: AnsiChar; WithMS: boolean; QuotedChar: AnsiChar): RawUTF8;
var tmp: array[0..31] of AnsiChar;
begin // D=0 is handled in DateTimeToIso8601Text()
FastSetString(result,@tmp,DateTimeToIso8601(@tmp,D,Expanded,FirstChar,WithMS,QuotedChar));
end;
function DateToIso8601(Date: TDateTime; Expanded: boolean): RawUTF8;
// use YYYYMMDD / YYYY-MM-DD date format
begin
FastSetString(result,nil,8+2*integer(Expanded));
DateToIso8601PChar(Date,pointer(result),Expanded);
end;
function DateToIso8601(Y,M,D: cardinal; Expanded: boolean): RawUTF8;
// use 'YYYYMMDD' format if not Expanded, 'YYYY-MM-DD' format if Expanded
begin
FastSetString(result,nil,8+2*integer(Expanded));
DateToIso8601PChar(pointer(result),Expanded,Y,M,D);
end;
function TimeToIso8601(Time: TDateTime; Expanded: boolean; FirstChar: AnsiChar;
WithMS: boolean): RawUTF8;
// use Thhmmss[.sss] / Thh:mm:ss[.sss] format
begin
FastSetString(result,nil,7+2*integer(Expanded)+4*integer(WithMS));
TimeToIso8601PChar(Time,pointer(result),Expanded,FirstChar,WithMS);
end;
function DateTimeToIso8601Text(DT: TDateTime; FirstChar: AnsiChar;
WithMS: boolean): RawUTF8;
begin
DateTimeToIso8601TextVar(DT,FirstChar,result,WithMS);
end;
procedure DateTimeToIso8601TextVar(DT: TDateTime; FirstChar: AnsiChar;
var result: RawUTF8; WithMS: boolean);
begin
if DT=0 then
result := '' else
if frac(DT)=0 then
result := DateToIso8601(DT,true) else
if trunc(DT)=0 then
result := TimeToIso8601(DT,true,FirstChar,WithMS) else
result := DateTimeToIso8601(DT,true,FirstChar,WithMS);
end;
procedure DateTimeToIso8601StringVar(DT: TDateTime; FirstChar: AnsiChar;
var result: string; WithMS: boolean);
var tmp: RawUTF8;
begin
DateTimeToIso8601TextVar(DT,FirstChar,tmp,WithMS);
Ansi7ToString(Pointer(tmp),length(tmp),result);
end;
function DateTimeToIso8601ExpandedPChar(const Value: TDateTime; Dest: PUTF8Char;
FirstChar: AnsiChar; WithMS: boolean): PUTF8Char;
begin
if Value<>0 then begin
if trunc(Value)<>0 then
Dest := DateToIso8601PChar(Value,Dest,true);
if frac(Value)<>0 then
Dest := TimeToIso8601PChar(Value,Dest,true,FirstChar,WithMS);
end;
Dest^ := #0;
result := Dest;
end;
function Iso8601ToTimeLogPUTF8Char(P: PUTF8Char; L: integer; ContainsNoTime: PBoolean): TTimeLog;
// bits: S=0..5 M=6..11 H=12..16 D=17..21 M=22..25 Y=26..40
// i.e. S<64 M<64 H<32 D<32 M<16 Y<9999: power of 2 -> use fast shl/shr
var V,B: PtrUInt;
tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif};
begin
result := 0;
if P=nil then
exit;
if L=0 then
L := StrLen(P);
if L<4 then
exit; // we need 'YYYY' at least
if P[0]='T' then
dec(P,8) else begin // 'YYYY' -> year decode
{$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC/x86_64
V := tab[ord(P[0])];
if V>9 then exit;
B := tab[ord(P[1])];
if B>9 then exit else V := V*10+B;
B := tab[ord(P[2])];
if B>9 then exit else V := V*10+B;
B := tab[ord(P[3])];
if B>9 then exit else V := V*10+B;
result := Int64(V) shl 26; // store YYYY
if P[4] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD
if L>=6 then begin // YYYYMM
V := ord(P[4])*10+ord(P[5])-(48+480+1); // Month 1..12 -> 0..11
if V<=11 then
inc(result,V shl 22) else begin
result := 0;
exit;
end;
if P[6] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD
if L>=8 then begin // YYYYMMDD
V := ord(P[6])*10+ord(P[7])-(48+480+1); // Day 1..31 -> 0..30
if (V<=30) and ((L=8) or (P[8] in [#0,' ','T'])) then
inc(result,V shl 17) else begin
result := 0;
exit;
end;
end;
end;
if L<15 then begin // not enough place to retrieve a time
if ContainsNoTime<>nil then
ContainsNoTime^ := true;
exit;
end;
end;
if ContainsNoTime<>nil then
ContainsNoTime^ := false;
B := ord(P[9])*10+ord(P[10])-(48+480);
if B<=23 then V := B shl 12 else exit;
if P[11]=':' then inc(P); // allow hh:mm:ss
B := ord(P[11])*10+ord(P[12])-(48+480);
if B<=59 then inc(V,B shl 6) else exit;
if P[13]=':' then inc(P); // allow hh:mm:ss
B := ord(P[13])*10+ord(P[14])-(48+480);
if B<=59 then inc(result,PtrUInt(V+B));
end;
function IsIso8601(P: PUTF8Char; L: integer): boolean;
begin
result := Iso8601ToTimeLogPUTF8Char(P,L)<>0;
end;
function DateTimeToi18n(const DateTime: TDateTime): string;
begin
if Assigned(i18nDateTimeText) then
result := i18nDateTimeText(DateTime) else
result := {$ifdef UNICODE}Ansi7ToString{$endif}(DateTimeToIso8601(DateTime,true,' ',true));
end;
{ TTimeLogBits }
// bits: S=0..5 M=6..11 H=12..16 D=17..21 M=22..25 Y=26..40
// size: S=6 M=6 H=5 D=5 M=4 Y=12
// i.e. S<64 M<64 H<32 D<32 M<16 Y<=9999: power of 2 -> use fast shl/shr
procedure TTimeLogBits.From(Y, M, D, HH, MM, SS: cardinal);
begin
inc(HH,D shl 5+M shl 10+Y shl 14-(1 shl 5+1 shl 10));
Value := SS+MM shl 6+Int64(HH) shl 12;
end;
procedure TTimeLogBits.From(P: PUTF8Char; L: integer);
begin
Value := Iso8601ToTimeLogPUTF8Char(P,L);
end;
procedure TTimeLogBits.Expand(out Date: TSynSystemTime);
var V: PtrUInt;
begin
V := PPtrUint(@Value)^;
Date.Year := {$ifdef CPU32}Value{$else}V{$endif} shr (6+6+5+5+4);
Date.Month := 1+(V shr (6+6+5+5)) and 15;
Date.DayOfWeek := 0;
Date.Day := 1+(V shr (6+6+5)) and 31;
Date.Hour := (V shr (6+6)) and 31;
Date.Minute := (V shr 6) and 63;
Date.Second := V and 63;
end;
procedure TTimeLogBits.From(const S: RawUTF8);
begin
Value := Iso8601ToTimeLogPUTF8Char(pointer(S),length(S));
end;
procedure TTimeLogBits.From(FileDate: integer);
begin
{$ifdef MSWINDOWS}
From(PInt64Rec(@FileDate)^.Hi shr 9+1980,
PInt64Rec(@FileDate)^.Hi shr 5 and 15,
PInt64Rec(@FileDate)^.Hi and 31,
PInt64Rec(@FileDate)^.Lo shr 11,
PInt64Rec(@FileDate)^.Lo shr 5 and 63,
PInt64Rec(@FileDate)^.Lo and 31 shl 1);
{$else} // FileDate depends on the running OS
From(FileDateToDateTime(FileDate));
{$endif}
end;
procedure TTimeLogBits.From(DateTime: TDateTime; DateOnly: Boolean);
var T: TSynSystemTime;
V: PtrInt;
begin
T.FromDate(DateTime);
if DateOnly then
T.Hour := 0 else
T.FromTime(DateTime);
V := T.Day shl 5+T.Month shl 10+T.Year shl 14-(1 shl 5+1 shl 10);
Value := V; // circumvent C1093 error on Delphi 5
Value := Value shl 12;
if not DateOnly then begin
V := T.Second+T.Minute shl 6+T.Hour shl 12;
Value := Value+V;
end;
end;
procedure TTimeLogBits.FromUnixTime(const UnixTime: TUnixTime);
begin
From(UnixTimeToDateTime(UnixTime));
end;
procedure TTimeLogBits.FromUnixMSTime(const UnixMSTime: TUnixMSTime);
begin
From(UnixMSTimeToDateTime(UnixMSTime));
end;
procedure TTimeLogBits.From(Time: PSynSystemTime);
var V: PtrInt;
begin
V := Time^.Hour+Time^.Day shl 5+Time^.Month shl 10+Time^.Year shl 14-(1 shl 5+1 shl 10);
Value := V; // circumvent C1093 error on Delphi 5
V := Time^.Second+Time^.Minute shl 6;
Value := (Value shl 12)+V;
end;
var // GlobalTime[LocalTime] cache protected using RCU128()
GlobalTime: array[boolean] of record
time: TSystemTime;
clock: PtrInt; // avoid slower API call with 8-16ms loss of precision
end;
{$ifndef FPC}{$ifdef CPUINTEL} // intrinsic in FPC
procedure ReadBarrier;
asm
{$ifdef CPUX86}
lock add dword ptr [esp], 0
{$else}
lfence // lfence requires an SSE CPU, which is OK on x86-64
{$endif}
end;
{$endif}{$endif}
procedure RCU32(var src,dst);
begin
repeat
Integer(dst) := Integer(src);
ReadBarrier;
until Integer(dst)=Integer(src);
end;
procedure RCU64(var src,dst);
begin
repeat
Int64(dst) := Int64(src);
ReadBarrier;
until Int64(dst)=Int64(src);
end;
procedure RCUPtr(var src,dst);
begin
repeat
PtrInt(dst) := PtrInt(src);
ReadBarrier;
until PtrInt(dst)=PtrInt(src);
end;
procedure RCU128(var src,dst);
var s: THash128Rec absolute src;
d: THash128Rec absolute dst;
begin
repeat
d := s;
ReadBarrier;
until (d.L=s.L) and (d.H=s.H);
end;
procedure RCU(var src,dst; len: integer);
begin
if len>0 then
repeat
MoveSmall(@src,@dst,len); // per-byte inlined copy
ReadBarrier;
until CompareMemSmall(@src,@dst,len);
end;
procedure FromGlobalTime(LocalTime: boolean; out NewTime: TSynSystemTime);
var tix: PtrInt;
newtimesys: TSystemTime absolute NewTime;
begin
with GlobalTime[LocalTime] do begin
tix := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64
{$ifndef MSWINDOWS}shr 3{$endif}; // Linux: 8ms refresh
if clock<>tix then begin // Windows: typically in range of 10-16 ms
clock := tix;
NewTime.Clear;
if LocalTime then
GetLocalTime(newtimesys) else
{$ifdef MSWINDOWS}GetSystemTime{$else}GetNowUTCSystem{$endif}(newtimesys);
RCU128(newtimesys,time);
end else
RCU128(time,NewTime);
end;
{$ifndef MSWINDOWS} // those TSystemTime fields are inverted in datih.inc :(
tix := newtimesys.DayOfWeek;
NewTime.Day := newtimesys.Day;
NewTime.DayOfWeek := tix;
{$endif}
end;
procedure TTimeLogBits.FromUTCTime;
var now: TSynSystemTime;
begin
FromGlobalTime(false,now);
From(@now);
end;
procedure TTimeLogBits.FromNow;
var now: TSynSystemTime;
begin
FromGlobalTime(true,now);
From(@now);
end;
function TTimeLogBits.ToTime: TDateTime;
var lo: PtrUInt;
begin
lo := {$ifdef CPU64}Value{$else}PCardinal(@Value)^{$endif};
if lo and (1 shl (6+6+5)-1)=0 then
result := 0 else
result := EncodeTime((lo shr(6+6))and 31, (lo shr 6)and 63, lo and 63, 0);
end;
function IsLeapYear(Year: cardinal): boolean;
var d100: TDiv100Rec;
begin
if Year and 3 = 0 then begin
Div100(Year,d100);
result := ((d100.M <> 0) or // (Year mod 100 > 0)
(Year - ((d100.D shr 2) * 400) = 0)); // (Year mod 400 = 0))
end else
result := false;
end;
function TryEncodeDate(Year, Month, Day: cardinal; out Date: TDateTime): Boolean;
var d100: TDiv100Rec;
begin // faster version by AB
result := False;
if (Year>0) and (Year<10000) and (Month>0) and (Month<13) and (Day>0) and
(Day <= MonthDays[IsLeapYear(Year)][Month]) then begin
if Month>2 then
dec(Month,3) else
if (Month>0) then begin
inc(Month,9);
dec(Year);
end
else exit; // Month <= 0
Div100(Year,d100);
Date := (146097*d100.D) shr 2+(1461*d100.M) shr 2+
(153*Month+2) div 5+Day;
Date := Date-693900; // should be separated to avoid sign issues
result := true;
end;
end;
function TTimeLogBits.ToDate: TDateTime;
var Y, lo: PtrUInt;
begin
{$ifdef CPU64}
lo := Value;
Y := lo shr (6+6+5+5+4);
{$else}
Y := Value shr (6+6+5+5+4);
lo := PCardinal(@Value)^;
{$endif}
if (Y=0) or not TryEncodeDate(Y,1+(lo shr(6+6+5+5))and 15,1+(lo shr(6+6+5))and 31,result) then
result := 0;
end;
function TTimeLogBits.ToDateTime: TDateTime;
var Y, lo: PtrUInt;
Time: TDateTime;
begin
{$ifdef CPU64}
lo := Value;
Y := lo shr (6+6+5+5+4);
{$else}
Y := Value shr (6+6+5+5+4);
lo := PCardinal(@Value)^;
{$endif}
if (Y=0) or not TryEncodeDate(Y,1+(lo shr(6+6+5+5))and 15,1+(lo shr(6+6+5))and 31,result) then
result := 0;
if (lo and (1 shl(6+6+5)-1)<>0) and TryEncodeTime((lo shr(6+6)) and 31,
(lo shr 6)and 63, lo and 63, 0, Time) then
result := result+Time;
end;
function TTimeLogBits.Year: Integer;
begin
result := Value shr (6+6+5+5+4);
end;
function TTimeLogBits.Month: Integer;
begin
result := 1+(PCardinal(@Value)^ shr (6+6+5+5)) and 15;
end;
function TTimeLogBits.Day: Integer;
begin
result := 1+(PCardinal(@Value)^ shr (6+6+5)) and 31;
end;
function TTimeLogBits.Hour: Integer;
begin
result := (PCardinal(@Value)^ shr (6+6)) and 31;
end;
function TTimeLogBits.Minute: Integer;
begin
result := (PCardinal(@Value)^ shr 6) and 63;
end;
function TTimeLogBits.Second: Integer;
begin
result := PCardinal(@Value)^ and 63;
end;
function TTimeLogBits.ToUnixTime: TUnixTime;
begin
result := DateTimeToUnixTime(ToDateTime);
end;
function TTimeLogBits.ToUnixMSTime: TUnixMSTime;
begin
result := DateTimeToUnixMSTime(ToDateTime);
end;
function TTimeLogBits.Text(Dest: PUTF8Char; Expanded: boolean; FirstTimeChar: AnsiChar): integer;
var lo: PtrUInt;
S: PUTF8Char;
begin
if Value=0 then begin
result := 0;
exit;
end;
S := Dest;
lo := {$ifdef CPU64}Value{$else}PCardinal(@Value)^{$endif};
if lo and (1 shl (6+6+5)-1)=0 then
// no Time: just convert date
result := DateToIso8601PChar(Dest, Expanded,
{$ifdef CPU64}lo{$else}Value{$endif} shr (6+6+5+5+4),
1+(lo shr (6+6+5+5)) and 15, 1+(lo shr (6+6+5)) and 31)-S else
if {$ifdef CPU64}lo{$else}Value{$endif} shr (6+6+5)=0 then
// no Date: just convert time
result := TimeToIso8601PChar(Dest, Expanded, (lo shr (6+6)) and 31,
(lo shr 6) and 63, lo and 63, 0, FirstTimeChar)-S else begin
// convert time and date
Dest := DateToIso8601PChar(Dest, Expanded,
{$ifdef CPU64}lo{$else}Value{$endif} shr (6+6+5+5+4),
1+(lo shr (6+6+5+5)) and 15, 1+(lo shr (6+6+5)) and 31);
result := TimeToIso8601PChar(Dest, Expanded, (lo shr (6+6)) and 31,
(lo shr 6) and 63, lo and 63, 0, FirstTimeChar)-S;
end;
end;
function TTimeLogBits.Text(Expanded: boolean; FirstTimeChar: AnsiChar): RawUTF8;
var tmp: array[0..31] of AnsiChar;
begin
if Value=0 then
result := '' else
FastSetString(result,@tmp,Text(tmp,Expanded,FirstTimeChar));
end;
function TTimeLogBits.FullText(Dest: PUTF8Char; Expanded: boolean;
FirstTimeChar,QuotedChar: AnsiChar): PUTF8Char;
var lo: PtrUInt;
begin // convert full time and date
if QuotedChar<>#0 then begin
Dest^ := QuotedChar;
inc(Dest);
end;
lo := {$ifdef CPU64}Value{$else}PCardinal(@Value)^{$endif};
Dest := DateToIso8601PChar(Dest, Expanded,
{$ifdef CPU64}lo{$else}Value{$endif} shr (6+6+5+5+4),
1+(lo shr (6+6+5+5)) and 15, 1+(lo shr (6+6+5)) and 31);
Dest := TimeToIso8601PChar(Dest, Expanded, (lo shr (6+6)) and 31,
(lo shr 6) and 63, lo and 63, 0, FirstTimeChar);
if QuotedChar<>#0 then begin
Dest^ := QuotedChar;
inc(Dest);
end;
result := Dest;
end;
function TTimeLogBits.FullText(Expanded: boolean; FirstTimeChar,QuotedChar: AnsiChar): RawUTF8;
var tmp: array[0..31] of AnsiChar;
begin
FastSetString(result,@tmp,FullText(tmp,Expanded,FirstTimeChar,QuotedChar)-@tmp);
end;
function TTimeLogBits.i18nText: string;
begin
if Assigned(i18nDateText) then
result := i18nDateText(Value) else
result := {$ifdef UNICODE}Ansi7ToString{$endif}(Text(true,' '));
end;
function TimeLogNow: TTimeLog;
begin
PTimeLogBits(@result)^.FromNow;
end;
function TimeLogNowUTC: TTimeLog;
begin
PTimeLogBits(@result)^.FromUTCTime;
end;
function NowToString(Expanded: boolean; FirstTimeChar: AnsiChar): RawUTF8;
var I: TTimeLogBits;
begin
I.FromNow;
result := I.Text(Expanded,FirstTimeChar);
end;
function NowUTCToString(Expanded: boolean; FirstTimeChar: AnsiChar): RawUTF8;
var I: TTimeLogBits;
begin
I.FromUTCTime;
result := I.Text(Expanded,FirstTimeChar);
end;
const
DTMS_FMT: array[boolean] of RawUTF8 = ('%%%%%%%%%', '%-%-%%%:%:%.%%');
function DateTimeMSToString(DateTime: TDateTime; Expanded: boolean;
FirstTimeChar: AnsiChar; const TZD: RawUTF8): RawUTF8;
var T: TSynSystemTime;
begin // 'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format
if DateTime=0 then
result := '' else begin
T.FromDateTime(DateTime);
result := DateTimeMSToString(T.Hour,T.Minute,T.Second,T.MilliSecond,
T.Year,T.Month,T.Day,Expanded,FirstTimeChar,TZD);
end;
end;
function DateTimeMSToString(HH,MM,SS,MS,Y,M,D: cardinal; Expanded: boolean;
FirstTimeChar: AnsiChar; const TZD: RawUTF8): RawUTF8;
begin // 'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format
FormatUTF8(DTMS_FMT[Expanded], [UInt4DigitsToShort(Y),UInt2DigitsToShortFast(M),
UInt2DigitsToShortFast(D),FirstTimeChar,UInt2DigitsToShortFast(HH),
UInt2DigitsToShortFast(MM),UInt2DigitsToShortFast(SS),UInt3DigitsToShort(MS),TZD], result);
end;
function DateTimeToHTTPDate(dt: TDateTime; const tz: RawUTF8): RawUTF8;
var T: TSynSystemTime;
begin
if dt=0 then
result := '' else begin
T.FromDateTime(dt);
T.ToHTTPDate(result,tz);
end;
end;
function TimeToString: RawUTF8;
var I: TTimeLogBits;
begin
I.FromNow;
I.Value := I.Value and (1 shl (6+6+5)-1); // keep only time
result := I.Text(true,' ');
end;
function TimeLogFromFile(const FileName: TFileName): TTimeLog;
var Date: TDateTime;
begin
Date := FileAgeToDateTime(FileName);
if Date=0 then
result := 0 else
PTimeLogBits(@result)^.From(Date);
end;
function TimeLogFromDateTime(const DateTime: TDateTime): TTimeLog;
begin
PTimeLogBits(@result)^.From(DateTime);
end;
function TimeLogFromUnixTime(const UnixTime: TUnixTime): TTimeLog;
begin
PTimeLogBits(@result)^.FromUnixTime(UnixTime);
end;
{ TSynDate }
procedure TSynDate.Clear;
begin
PInt64(@self)^ := 0;
end;
procedure TSynDate.SetMax;
begin
PInt64(@self)^ := $001F0000000C270F; // 9999 + 12 shl 16 + 31 shl 48
end;
function TSynDate.IsZero: boolean;
begin
result := PInt64(@self)^=0;
end;
function TSynDate.ParseFromText(var P: PUTF8Char): boolean;
var L: PtrInt;
Y,M,D: cardinal;
begin
result := false;
if P=nil then
exit;
while P^ in [#9,' '] do inc(P);
L := 0;
while P[L] in ['0'..'9','-','/'] do inc(L);
if not Iso8601ToDatePUTF8Char(P,L,Y,M,D) then
exit;
Year := Y;
Month := M;
DayOfWeek := 0;
Day := D;
inc(P,L); // move P^ just after the date
result := true;
end;
procedure TSynDate.FromNow(localtime: boolean);
var dt: TSynSystemTime;
begin
FromGlobalTime(localtime,dt);
self := PSynDate(@dt)^; // 4 first fields of TSynSystemTime do match
end;
procedure TSynDate.FromDate(date: TDate);
var dt: TSynSystemTime;
begin
dt.FromDate(date); // faster than DecodeDate
self := PSynDate(@dt)^;
end;
function TSynDate.IsEqual({$ifdef FPC}constref{$else}const{$endif} another{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): boolean;
begin
result := (PCardinal(@Year)^=PCardinal(@TSynDate(another).Year)^) and (Day=TSynDate(another).Day);
end;
function TSynDate.Compare({$ifdef FPC}constref{$else}const{$endif} another{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): integer;
begin
result := Year-TSynDate(another).Year;
if result=0 then begin
result := Month-TSynDate(another).Month;
if result=0 then
result := Day-TSynDate(another).Day;
end;
end;
procedure TSynDate.ComputeDayOfWeek;
var d: TDateTime;
i: PtrInt;
begin
if not TryEncodeDate(Year,Month,Day,d) then begin
DayOfWeek := 0;
exit;
end;
i := ((trunc(d)-1) mod 7)+1; // sunday is day 1
if i<=0 then
DayOfWeek := i+7 else
DayOfWeek := i;
end;
function TSynDate.ToDate: TDate;
begin
if not TryEncodeDate(Year,Month,Day,PDateTime(@result)^) then
result := 0;
end;
function TSynDate.ToText(Expanded: boolean): RawUTF8;
begin
if PInt64(@self)^=0 then
result := '' else
result := DateToIso8601(Year,Month,Day,Expanded);
end;
{ TSynSystemTime }
function TryEncodeDayOfWeekInMonth(AYear, AMonth, ANthDayOfWeek, ADayOfWeek: integer;
out AValue: TDateTime): Boolean;
var LStartOfMonth, LDay: integer;
begin // adapted from DateUtils
result := TryEncodeDate(AYear,AMonth,1,aValue);
if not result then
exit;
LStartOfMonth := (DateTimeToTimestamp(aValue).Date-1)mod 7+1;
if LStartOfMonth<=ADayOfWeek then
dec(ANthDayOfWeek);
LDay := (ADayOfWeek-LStartOfMonth+1)+7*ANthDayOfWeek;
result := TryEncodeDate(AYear,AMonth,LDay,AValue);
end;
function TSynSystemTime.EncodeForTimeChange(const aYear: word): TDateTime;
var dow,d: word;
begin
if DayOfWeek=0 then
dow := 7 else // Delphi Sunday = 7
dow := DayOfWeek;
// Encoding the day of change
d := Day;
while not TryEncodeDayOfWeekInMonth(aYear,Month,d,dow,Result) do begin
// if Day = 5 then try it and if needed decrement to find the last
// occurence of the day in this month
if d=0 then begin
TryEncodeDayOfWeekInMonth(aYear,Month,1,7,Result);
break;
end;
dec(d);
end;
// finally add the time when change is due
result := result+EncodeTime(Hour,Minute,Second,MilliSecond);
end;
procedure TSynSystemTime.Clear;
begin
PInt64Array(@self)[0] := 0;
PInt64Array(@self)[1] := 0;
end;
function TSynSystemTime.IsZero: boolean;
begin
result := (PInt64Array(@self)[0]=0) and (PInt64Array(@self)[1]=0);
end;
function TSynSystemTime.IsEqual(const another{$ifndef DELPHI5OROLDER}: TSynSystemTime{$endif}): boolean;
begin
result := (PInt64Array(@self)[0]=PInt64Array(@another)[0]) and
(PInt64Array(@self)[1]=PInt64Array(@another)[1]);
end;
function TSynSystemTime.IsDateEqual(const date{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): boolean;
begin
result := (PCardinal(@Year)^=PCardinal(@TSynDate(date).Year)^) and
(Day=TSynDate(date).Day);
end;
procedure TSynSystemTime.FromNowUTC;
begin
FromGlobalTime(false,self);
end;
procedure TSynSystemTime.FromNowLocal;
begin
FromGlobalTime(true,self);
end;
procedure TSynSystemTime.FromDateTime(const dt: TDateTime);
begin
FromDate(dt);
FromTime(dt);
end;
procedure TSynSystemTime.FromDate(const dt: TDateTime);
var t,t2,t3: PtrUInt;
begin
t := Trunc(dt);
t := (t+693900)*4-1;
if PtrInt(t)>=0 then begin
t3 := t div 146097;
t2 := (t-t3*146097) and not 3;
t := PtrUInt(t2+3) div 1461; // PtrUInt() needed for FPC i386
Year := t3*100+t;
t2 := ((t2+7-t*1461)shr 2)*5;
t3 := PtrUInt(t2-3) div 153;
Day := PtrUInt(t2+2-t3*153) div 5;
if t3<10 then
inc(t3,3) else begin
dec(t3,9);
inc(Year);
end;
Month := t3;
DayOfWeek := 0; // not set by default
end else
PInt64(@Year)^ := 0;
end;
procedure TSynSystemTime.FromTime(const dt: TDateTime);
begin
FromMS(QWord(round(abs(dt)*MSecsPerDay)) mod MSecsPerDay);
end;
procedure TSynSystemTime.FromMS(ms: PtrUInt);
var t: PtrUInt;
begin
t := ms div 3600000;
Hour := t;
dec(ms,t*3600000);
t := ms div 60000;
Minute := t;
dec(ms,t*60000);
t := ms div 1000;
Second := t;
dec(ms,t*1000);
MilliSecond := ms;
end;
procedure TSynSystemTime.FromSec(s: PtrUInt);
var t: PtrUInt;
begin
t := s div 3600;
Hour := t;
dec(s,t*3600);
t := s div 60;
Minute := t;
dec(s,t*60);
Second := s;
MilliSecond := 0;
end;
function TSynSystemTime.FromText(const iso: RawUTF8): boolean;
var t: TTimeLogBits;
begin
t.From(iso);
if t.Value=0 then
result := false else begin
t.Expand(self); // TTimeLogBits is faster than FromDateTime()
result := true;
end;
end;
function TSynSystemTime.ToText(Expanded: boolean;
FirstTimeChar: AnsiChar; const TZD: RawUTF8): RawUTF8;
begin
result := DateTimeMSToString(Hour,Minute,Second,MilliSecond,Year,Month,Day,
Expanded,FirstTimeChar,TZD);
end;
procedure TSynSystemTime.AddLogTime(WR: TTextWriter);
var y,d100: PtrUInt;
P: PUTF8Char;
tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif};
begin
if WR.BEnd-WR.B<=18 then
WR.FlushToStream;
{$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif}
y := Year;
d100 := y div 100;
P := WR.B+1;
PWord(P)^ := tab[d100];
PWord(P+2)^ := tab[y-(d100*100)];
PWord(P+4)^ := tab[Month];
PWord(P+6)^ := tab[Day];
P[8] := ' ';
PWord(P+9)^ := tab[Hour];
PWord(P+11)^ := tab[Minute];
PWord(P+13)^ := tab[Second];
y := Millisecond;
PWord(P+15)^ := tab[y shr 4];
inc(WR.B,17);
end;
const
HTML_WEEK_DAYS: array[1..7] of string[3] =
('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
HTML_MONTH_NAMES: array[1..12] of string[3] =
('Jan','Feb','Mar','Apr','May','Jun', 'Jul','Aug','Sep','Oct','Nov','Dec');
function TSynSystemTime.ToNCSAText(P: PUTF8Char): PtrInt;
var y,d100: PtrUInt;
tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif};
begin
{$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif}
PWord(P)^ := tab[Day];
PCardinal(P+2)^ := PCardinal(@HTML_MONTH_NAMES[Month])^;
P[2] := '/'; // overwrite HTML_MONTH_NAMES[][0]
P[6] := '/';
y := Year;
d100 := y div 100;
PWord(P+7)^ := tab[d100];
PWord(P+9)^ := tab[y-(d100*100)];
P[11] := ':';
PWord(P+12)^ := tab[Hour];
P[14] := ':';
PWord(P+15)^ := tab[Minute];
P[17] := ':';
PWord(P+18)^ := tab[Second];
P[20] := ' ';
result := 21;
end;
procedure TSynSystemTime.ToHTTPDate(out text: RawUTF8; const tz: RawUTF8);
begin
if DayOfWeek=0 then
PSynDate(@self)^.ComputeDayOfWeek; // first 4 fields do match
FormatUTF8('%, % % % %:%:% %', [HTML_WEEK_DAYS[DayOfWeek],
UInt2DigitsToShortFast(Day),HTML_MONTH_NAMES[Month],UInt4DigitsToShort(Year),
UInt2DigitsToShortFast(Hour),UInt2DigitsToShortFast(Minute),
UInt2DigitsToShortFast(Second),tz],text);
end;
procedure TSynSystemTime.ToIsoDateTime(out text: RawUTF8; const FirstTimeChar: AnsiChar);
begin
FormatUTF8('%-%-%%%:%:%', [UInt4DigitsToShort(Year),UInt2DigitsToShortFast(Month),
UInt2DigitsToShortFast(Day),FirstTimeChar,UInt2DigitsToShortFast(Hour),
UInt2DigitsToShortFast(Minute),UInt2DigitsToShortFast(Second)],text);
end;
procedure TSynSystemTime.ToIsoDate(out text: RawUTF8);
begin
FormatUTF8('%-%-%', [UInt4DigitsToShort(Year),UInt2DigitsToShortFast(Month),
UInt2DigitsToShortFast(Day)],text);
end;
procedure TSynSystemTime.ToIsoTime(out text: RawUTF8; const FirstTimeChar: RawUTF8);
begin
FormatUTF8('%%:%:%', [FirstTimeChar,UInt2DigitsToShortFast(Hour),
UInt2DigitsToShortFast(Minute),UInt2DigitsToShortFast(Second)],text);
end;
procedure TSynSystemTime.AddNCSAText(WR: TTextWriter);
begin
if WR.BEnd-WR.B<=21 then
WR.FlushToStream;
inc(WR.B,ToNCSAText(WR.B+1));
end;
function TSynSystemTime.ToDateTime: TDateTime;
var time: TDateTime;
begin
if TryEncodeDate(Year,Month,Day,result) then
if TryEncodeTime(Hour,Minute,Second,MilliSecond,time) then
result := result+time else
result := 0 else
result := 0;
end;
procedure TSynSystemTime.ToSynDate(out date: TSynDate);
begin
date := PSynDate(@self)^; // first 4 fields do match
end;
procedure TSynSystemTime.ComputeDayOfWeek;
begin
PSynDate(@self)^.ComputeDayOfWeek; // first 4 fields do match
end;
procedure TSynSystemTime.IncrementMS(ms: integer);
begin
inc(MilliSecond, ms);
if MilliSecond >= 1000 then
repeat
dec(MilliSecond, 1000);
if Second < 60 then
inc(Second)
else begin
Second := 0;
if Minute < 60 then
inc(Minute)
else begin
Minute := 0;
if Hour < 24 then
inc(Hour)
else begin
Hour := 0;
if Day < MonthDays[false, Month] then
inc(Day)
else begin
Day := 1;
if Month < 12 then
inc(Month)
else begin
Month := 1;
inc(Year);
end;
end;
end;
end;
end;
until MilliSecond < 1000;
end;
procedure AppendToTextFile(aLine: RawUTF8; const aFileName: TFileName;
aMaxSize: Int64; aUTCTimeStamp: boolean);
var F: THandle;
Old: TFileName;
Date: array[1..22] of AnsiChar;
size: Int64;
i: integer;
now: TSynSystemTime;
begin
if aFileName='' then
exit;
F := FileOpen(aFileName,fmOpenWrite or fmShareDenyNone);
if PtrInt(F)<0 then begin
F := FileCreate(aFileName);
if PtrInt(F)<0 then
exit; // you may not have write access to this folder
end;
// append to end of file
size := FileSeek64(F,0,soFromEnd);
if (aMaxSize>0) and (size>aMaxSize) then begin
// rotate log file if too big
FileClose(F);
Old := aFileName+'.bak'; // '.log.bak'
DeleteFile(Old); // rotate once
RenameFile(aFileName,Old);
F := FileCreate(aFileName);
if PtrInt(F)<0 then
exit;
end;
PWord(@Date)^ := 13+10 shl 8; // first go to next line
if aUTCTimeStamp then
now.FromNowUTC else
now.FromNowLocal;
DateToIso8601PChar(@Date[3],true,Now.Year,Now.Month,Now.Day);
TimeToIso8601PChar(@Date[13],true,Now.Hour,Now.Minute,Now.Second,0,' ');
Date[22] := ' ';
FileWrite(F,Date,SizeOf(Date));
for i := 1 to length(aLine) do
if aLine[i]<' ' then
aLine[i] := ' '; // avoid line feed in text log file
FileWrite(F,pointer(aLine)^,length(aLine));
FileClose(F);
end;
procedure LogToTextFile(Msg: RawUTF8);
begin
if Msg='' then begin
StringToUTF8(SysErrorMessage(GetLastError),Msg);
if Msg='' then
exit;
end;
AppendToTextFile(Msg,{$ifndef MSWINDOWS}ExtractFileName{$endif}
(ChangeFileExt(ExeVersion.ProgramFileName,'.log')));
end;
function IsEqualGUID(const guid1, guid2: TGUID): Boolean;
begin
result := (PHash128Rec(@guid1).L=PHash128Rec(@guid2).L) and
(PHash128Rec(@guid1).H=PHash128Rec(@guid2).H);
end;
function IsEqualGUID(guid1, guid2: PGUID): Boolean;
begin
result := (PHash128Rec(guid1).L=PHash128Rec(guid2).L) and
(PHash128Rec(guid1).H=PHash128Rec(guid2).H);
end;
function IsEqualGUIDArray(const guid: TGUID; const guids: array of TGUID): integer;
begin
result := Hash128Index(@guids[0],length(guids),@guid);
end;
function IsNullGUID({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): Boolean;
var a: TPtrIntArray absolute guid;
begin
result := (a[0]=0) and (a[1]=0) {$ifndef CPU64} and (a[2]=0) and (a[3]=0){$endif};
end;
function AddGUID(var guids: TGUIDDynArray; const guid: TGUID;
NoDuplicates: boolean): integer;
begin
if NoDuplicates then begin
result := Hash128Index(pointer(guids),length(guids),@guid);
if result>=0 then
exit;
end;
result := length(guids);
SetLength(guids,result+1);
guids[result] := guid;
end;
function GUIDToText(P: PUTF8Char; guid: PByteArray): PUTF8Char;
var i: integer;
begin // encode as '3F2504E0-4F89-11D3-9A0C-0305E82C3301'
for i := 3 downto 0 do begin
PWord(P)^ := TwoDigitsHexWB[guid[i]];
inc(P,2);
end;
inc(PByte(guid),4);
for i := 1 to 2 do begin
P[0] := '-';
PWord(P+1)^ := TwoDigitsHexWB[guid[1]];
PWord(P+3)^ := TwoDigitsHexWB[guid[0]];
inc(PByte(guid),2);
inc(P,5);
end;
P[0] := '-';
PWord(P+1)^ := TwoDigitsHexWB[guid[0]];
PWord(P+3)^ := TwoDigitsHexWB[guid[1]];
P[5] := '-';
inc(PByte(guid),2);
inc(P,6);
for i := 0 to 5 do begin
PWord(P)^ := TwoDigitsHexWB[guid[i]];
inc(P,2);
end;
result := P;
end;
function HexaToByte(P: PUTF8Char; var Dest: byte): boolean; {$ifdef HASINLINE}inline;{$endif}
var B,C: PtrUInt;
begin
B := ConvertHexToBin[Ord(P[0])];
if B<=15 then begin
C := ConvertHexToBin[Ord(P[1])];
if C<=15 then begin
Dest := B shl 4+C;
result := true;
exit;
end;
end;
result := false; // mark error
end;
function TextToGUID(P: PUTF8Char; guid: PByteArray): PUTF8Char;
var i: integer;
begin // decode from '3F2504E0-4F89-11D3-9A0C-0305E82C3301'
result := nil;
for i := 3 downto 0 do begin
if not HexaToByte(P,guid[i]) then
exit;
inc(P,2);
end;
inc(PByte(guid),4);
for i := 1 to 2 do begin
if (P^<>'-') or not HexaToByte(P+1,guid[1]) or not HexaToByte(P+3,guid[0]) then
exit;
inc(P,5);
inc(PByte(guid),2);
end;
if (P[0]<>'-') or (P[5]<>'-') or
not HexaToByte(P+1,guid[0]) or not HexaToByte(P+3,guid[1]) then
exit;
inc(PByte(guid),2);
inc(P,6);
for i := 0 to 5 do
if HexaToByte(P,guid[i]) then
inc(P,2) else
exit;
result := P;
end;
function GUIDToRawUTF8({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): RawUTF8;
var P: PUTF8Char;
begin
FastSetString(result,nil,38);
P := pointer(result);
P^ := '{';
GUIDToText(P+1,@guid)^ := '}';
end;
function GUIDToShort({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): TGUIDShortString;
begin
GUIDToShort(guid,result);
end;
procedure GUIDToShort({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID;
out dest: TGUIDShortString);
begin
dest[0] := #38;
dest[1] := '{';
dest[38] := '}';
GUIDToText(@dest[2],@guid);
end;
function GUIDToString({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): string;
{$ifdef UNICODE}
var tmp: array[0..35] of AnsiChar;
i: integer;
begin
GUIDToText(tmp,@guid);
SetString(result,nil,38);
PWordArray(result)[0] := ord('{');
for i := 1 to 36 do
PWordArray(result)[i] := ord(tmp[i-1]); // no conversion for 7 bit Ansi
PWordArray(result)[37] := ord('}');
end;
{$else}
begin
result := GUIDToRawUTF8(guid);
end;
{$endif}
{$ifdef CPUINTEL} /// NIST SP 800-90A compliant RDRAND Intel x86/x64 opcode
function RdRand32: cardinal; {$ifdef CPU64}
{$ifdef FPC}nostackframe; assembler; asm{$else} asm .noframe {$endif FPC} {$else}
{$ifdef FPC}nostackframe; assembler;{$endif} asm {$endif}
// rdrand eax: same opcodes for x86 and x64
db $0f, $c7, $f0
// returns in eax, ignore carry flag (eax=0 won't hurt)
end;
{$endif CPUINTEL}
threadvar
_Lecuyer: TLecuyer; // uses only 16 bytes per thread
procedure TLecuyer.Seed(entropy: PByteArray; entropylen: PtrInt);
var time, crc: THash128Rec;
i, j: PtrInt;
begin
repeat
QueryPerformanceCounter(time.Lo);
time.Hi := UnixMSTimeUTCFast xor PtrUInt(GetCurrentThreadID);
crcblock(@crc.b,@time.b);
crcblock(@crc.b,@ExeVersion.Hash.b);
if entropy<>nil then
for i := 0 to entropylen-1 do begin
j := i and 15;
crc.b[j] := crc.b[j] xor entropy^[i];
end;
rs1 := rs1 xor crc.c0;
rs2 := rs2 xor crc.c1;
rs3 := rs3 xor crc.c2;
{$ifdef CPUINTEL}
if cfRAND in CpuFeatures then begin // won't hurt e.g. from Random32gsl
rs1 := rs1 xor RdRand32;
rs2 := rs2 xor RdRand32;
rs3 := rs3 xor RdRand32;
end;
{$endif CPUINTEL}
until (rs1>1) and (rs2>7) and (rs3>15);
seedcount := 1;
for i := 1 to crc.i3 and 15 do
Next; // warm up
end;
function TLecuyer.Next: cardinal;
begin
if word(seedcount)=0 then // reseed after 256KB of output
Seed(nil,0) else
inc(seedcount);
result := rs1;
rs1 := ((result and -2)shl 12) xor (((result shl 13)xor result)shr 19);
result := rs2;
rs2 := ((result and -8)shl 4) xor (((result shl 2)xor result)shr 25);
result := rs3;
rs3 := ((result and -16)shl 17) xor (((result shl 3)xor result)shr 11);
result := rs1 xor rs2 xor result;
end;
function TLecuyer.Next(max: cardinal): cardinal;
begin
result := (QWord(Next)*max)shr 32;
end;
procedure Random32Seed(entropy: pointer; entropylen: PtrInt);
begin
_Lecuyer.Seed(entropy,entropylen);
end;
function Random32: cardinal;
begin
{$ifdef CPUINTEL}
if cfRAND in CpuFeatures then begin
result := RdRand32;
if ((integer(result)<>-1) and (result<>0)) or (RdRand32<>result) then
exit; // ensure not affected by old AMD bug after suspend to RAM
exclude(CpuFeatures,cfRAND); // disable if weakness detected
end;
{$endif CPUINTEL}
result := _Lecuyer.Next;
end;
function Random32(max: cardinal): cardinal;
begin
result := (QWord(Random32)*max)shr 32;
end;
function Random32gsl: cardinal;
begin
result := _Lecuyer.Next;
end;
function Random32gsl(max: cardinal): cardinal;
begin
result := (QWord(_Lecuyer.Next)*max)shr 32;
end;
procedure FillRandom(Dest: PCardinalArray; CardinalCount: integer; forcegsl: boolean);
var i: PtrInt;
c: cardinal;
seed: TQWordRec;
lecuyer: ^TLecuyer;
begin
if CardinalCount<=0 then
exit;
{$ifdef CPUINTEL}
if (cfRAND in CpuFeatures) and not forcegsl then
lecuyer := nil else
{$endif CPUINTEL}
lecuyer := @_Lecuyer;
QueryPerformanceCounter(PInt64(@seed)^);
c := crc32cBy4(seed.L,seed.H);
for i := 0 to CardinalCount-1 do begin
{$ifdef CPUINTEL}
if lecuyer=nil then
c := crc32cBy4(c,RdRand32) else // never trust plain Intel values
{$endif CPUINTEL}
c := c xor lecuyer^.Next;
Dest^[i] := Dest^[i] xor c;
end;
end;
function RandomGUID: TGUID;
begin
FillRandom(@result,SizeOf(TGUID) shr 2,{forcegsl=}true);
end;
procedure RandomGUID(out result: TGUID);
begin
FillRandom(@result,SizeOf(TGUID) shr 2,{forcegsl=}true);
end;
procedure FillZero(var result: TGUID);
begin
FillZero(PHash128(@result)^);
end;
function RawUTF8ToGUID(const text: RawByteString): TGUID;
begin
if (length(text)<>38) or (text[1]<>'{') or (text[38]<>'}') or
(TextToGUID(@text[2],@result)=nil) then
FillZero(PHash128(@result)^);
end;
function StringToGUID(const text: string): TGUID;
{$ifdef UNICODE}
var tmp: array[0..35] of byte;
i: integer;
{$endif}
begin
if (length(text)=38) and (text[1]='{') and (text[38]='}') then begin
{$ifdef UNICODE}
for i := 0 to 35 do
tmp[i] := PWordArray(text)[i+1];
if TextToGUID(@tmp,@result)<>nil then
{$else}
if TextToGUID(@text[2],@result)<>nil then
{$endif}
exit; // conversion OK
end;
FillZero(PHash128(@result)^);
end;
function StrCurr64(P: PAnsiChar; const Value: Int64): PAnsiChar;
var c: QWord;
d: cardinal;
{$ifndef CPU64}c64: Int64Rec absolute c;{$endif}
begin
if Value=0 then begin
result := P-1;
result^ := '0';
exit;
end;
if Value<0 then
c := -Value else
c := Value;
if {$ifdef CPU64}c<10000{$else}(c64.Hi=0) and (c64.Lo<10000){$endif} then begin
result := P-6; // only decimals -> append '0.xxxx'
PWord(result)^ := ord('0')+ord('.')shl 8;
YearToPChar(c,PUTF8Char(P)-4);
end else begin
result := StrUInt64(P-1,c);
d := PCardinal(P-5)^; // in two explit steps for CPUARM (alf)
PCardinal(P-4)^ := d;
P[-5] := '.'; // insert '.' just before last 4 decimals
end;
if Value<0 then begin
dec(result);
result^ := '-';
end;
end;
procedure Curr64ToStr(const Value: Int64; var result: RawUTF8);
var tmp: array[0..31] of AnsiChar;
P: PAnsiChar;
Decim, L: Cardinal;
begin
if Value=0 then
result := SmallUInt32UTF8[0] else begin
P := StrCurr64(@tmp[31],Value);
L := @tmp[31]-P;
if L>4 then begin
Decim := PCardinal(P+L-SizeOf(cardinal))^; // 4 last digits = 4 decimals
if Decim=ord('0')+ord('0')shl 8+ord('0')shl 16+ord('0')shl 24 then
dec(L,5) else // no decimal
if Decim and $ffff0000=ord('0')shl 16+ord('0')shl 24 then
dec(L,2); // 2 decimals
end;
FastSetString(result,P,L);
end;
end;
function Curr64ToStr(const Value: Int64): RawUTF8;
begin
Curr64ToStr(Value,result);
end;
function CurrencyToStr(Value: currency): RawUTF8;
begin
result := Curr64ToStr(PInt64(@Value)^);
end;
function Curr64ToPChar(const Value: Int64; Dest: PUTF8Char): PtrInt;
var tmp: array[0..31] of AnsiChar;
P: PAnsiChar;
Decim: Cardinal;
begin
P := StrCurr64(@tmp[31],Value);
result := @tmp[31]-P;
if result>4 then begin
Decim := PCardinal(P+result-SizeOf(cardinal))^; // 4 last digits = 4 decimals
if Decim=ord('0')+ord('0')shl 8+ord('0')shl 16+ord('0')shl 24 then
dec(result,5) else // no decimal
if Decim and $ffff0000=ord('0')shl 16+ord('0')shl 24 then
dec(result,2); // 2 decimals
end;
MoveSmall(P,Dest,result);
end;
function StrToCurr64(P: PUTF8Char; NoDecimal: PBoolean): Int64;
var c: cardinal;
minus: boolean;
Dec: cardinal;
begin
result := 0;
if P=nil then
exit;
while (P^<=' ') and (P^<>#0) do inc(P);
if P^='-' then begin
minus := true;
repeat inc(P) until P^<>' ';
end else begin
minus := false;
if P^='+' then
repeat inc(P) until P^<>' ';
end;
if P^='.' then begin // '.5' -> 500
Dec := 2;
inc(P);
end else
Dec := 0;
c := byte(P^)-48;
if c>9 then
exit;
PCardinal(@result)^ := c;
inc(P);
repeat
if P^<>'.' then begin
c := byte(P^)-48;
if c>9 then
break;
{$ifdef CPU32DELPHI}
result := result shl 3+result+result;
{$else}
result := result*10;
{$endif}
inc(result,c);
inc(P);
if Dec<>0 then begin
inc(Dec);
if Dec<5 then continue else break;
end;
end else begin
inc(Dec);
inc(P);
end;
until false;
if NoDecimal<>nil then
if Dec=0 then begin
NoDecimal^ := true;
if minus then
result := -result;
exit;
end else
NoDecimal^ := false;
if Dec<>5 then // Dec=5 most of the time
case Dec of
0,1: result := result*10000;
{$ifdef CPU32DELPHI}
2: result := result shl 10-result shl 4-result shl 3;
3: result := result shl 6+result shl 5+result shl 2;
4: result := result shl 3+result+result;
{$else}
2: result := result*1000;
3: result := result*100;
4: result := result*10;
{$endif}
end;
if minus then
result := -result;
end;
function StrToCurrency(P: PUTF8Char): currency;
begin
PInt64(@result)^ := StrToCurr64(P,nil);
end;
function TruncTo2Digits(Value: Currency): Currency;
var V64: Int64 absolute Value; // to avoid any floating-point precision issues
begin
dec(V64,V64 mod 100);
result := Value;
end;
procedure TruncTo2DigitsCurr64(var Value: Int64);
begin
dec(Value,Value mod 100);
end;
function TruncTo2Digits64(Value: Int64): Int64;
begin
result := Value-Value mod 100;
end;
function SimpleRoundTo2Digits(Value: Currency): Currency;
var V64: Int64 absolute Value; // to avoid any floating-point precision issues
begin
SimpleRoundTo2DigitsCurr64(V64);
result := Value;
end;
procedure SimpleRoundTo2DigitsCurr64(var Value: Int64);
var Spare: PtrInt;
begin
Spare := Value mod 100;
if Spare<>0 then
if Spare>50 then
inc(Value,100-Spare) else
if Spare<-50 then
dec(Value,100+Spare) else
dec(Value,Spare);
end;
function TrimLeftLowerCase(const V: RawUTF8): PUTF8Char;
begin
result := Pointer(V);
if result<>nil then begin
while result^ in ['a'..'z'] do
inc(result);
if result^=#0 then
result := Pointer(V);
end;
end;
function TrimLeftLowerCaseToShort(V: PShortString): ShortString;
begin
TrimLeftLowerCaseToShort(V,result);
end;
procedure TrimLeftLowerCaseToShort(V: PShortString; out result: ShortString);
var P: PAnsiChar;
L: integer;
begin
L := length(V^);
P := @V^[1];
while (L>0) and (P^ in ['a'..'z']) do begin
inc(P);
dec(L);
end;
if L=0 then
result := V^ else
SetString(result,P,L);
end;
{$ifdef FPC_OR_PUREPASCAL}
function TrimLeftLowerCaseShort(V: PShortString): RawUTF8;
var P: PAnsiChar;
L: integer;
begin
L := length(V^);
P := @V^[1];
while (L>0) and (P^ in ['a'..'z']) do begin
inc(P);
dec(L);
end;
if L=0 then
FastSetString(result,@V^[1],length(V^)) else
FastSetString(result,P,L);
end;
{$else}
function TrimLeftLowerCaseShort(V: PShortString): RawUTF8;
asm // eax=V
xor ecx, ecx
push edx // save result RawUTF8
test eax, eax
jz @2 // avoid GPF
lea edx, [eax + 1]
mov cl, [eax]
@1: mov ch, [edx] // edx=source cl=length
sub ch, 'a'
sub ch, 'z' - 'a'
ja @2 // not a lower char -> create a result string starting at edx
inc edx
dec cl
jnz @1
mov cl, [eax]
lea edx, [eax + 1] // no UpperCase -> retrieve full text (result := V^)
@2: pop eax
movzx ecx, cl
{$ifdef UNICODE}
push CP_UTF8 // UTF-8 code page for Delphi 2009+ + call below, not jump
call System.@LStrFromPCharLen // eax=Dest edx=Source ecx=Length
rep ret // we need a call just above for right push CP_UTF8 retrieval
{$else} jmp System.@LStrFromPCharLen // eax=dest edx=source ecx=length(source)
{$endif}
end;
{$endif FPC_OR_PUREPASCAL}
function UnCamelCase(const S: RawUTF8): RawUTF8;
var tmp: TSynTempBuffer;
destlen: PtrInt;
begin
if S='' then
result := '' else begin
destlen := UnCamelCase(tmp.Init(length(S)*2),pointer(S));
tmp.Done(PAnsiChar(tmp.buf)+destlen,result);
end;
end;
function UnCamelCase(D, P: PUTF8Char): integer;
var Space, SpaceBeg, DBeg: PUTF8Char;
CapitalCount: integer;
Number: boolean;
label Next;
begin
DBeg := D;
if (D<>nil) and (P<>nil) then begin // avoid GPF
Space := D;
SpaceBeg := D;
repeat
CapitalCount := 0;
Number := P^ in ['0'..'9'];
if Number then
repeat
inc(CapitalCount);
D^ := P^;
inc(P);
inc(D);
until not (P^ in ['0'..'9']) else
repeat
inc(CapitalCount);
D^ := P^;
inc(P);
inc(D);
until not (P^ in ['A'..'Z']);
if P^=#0 then break; // no lowercase conversion of last fully uppercased word
if (CapitalCount > 1) and not Number then begin
dec(P);
dec(D);
end;
while P^ in ['a'..'z'] do begin
D^ := P^;
inc(D);
inc(P);
end;
if P^='_' then
if P[1]='_' then begin
D^ := ':';
inc(P);
inc(D);
goto Next;
end else begin
PWord(D)^ := ord(' ')+ord('-')shl 8;
inc(D,2);
Next: if Space=SpaceBeg then
SpaceBeg := D+1;
inc(P);
Space := D+1;
end else
Space := D;
if P^=#0 then break;
D^ := ' ';
inc(D);
until false;
if Space>DBeg then
dec(Space);
while Space>SpaceBeg do begin
if Space^ in ['A'..'Z'] then
if not (Space[1] in ['A'..'Z',' ']) then
inc(Space^,32); // lowercase conversion of not last fully uppercased word
dec(Space);
end;
end;
result := D-DBeg;
end;
procedure CamelCase(P: PAnsiChar; len: PtrInt; var s: RawUTF8;
const isWord: TSynByteSet);
var i: PtrInt;
d: PAnsiChar;
tmp: array[byte] of AnsiChar;
begin
if len > SizeOf(tmp) then
len := SizeOf(tmp);
for i := 0 to len-1 do
if not(ord(P[i]) in isWord) then begin
if i>0 then begin
MoveSmall(P,@tmp,i);
inc(P,i);
dec(len,i);
end;
d := @tmp[i];
while len > 0 do begin
while (len > 0) and not (ord(P^) in isWord) do begin
inc(P);
dec(len);
end;
if len = 0 then
break;
d^ := NormToUpperAnsi7[P^];
inc(d);
repeat
inc(P);
dec(len);
if not (ord(P^) in isWord) then
break;
d^ := P^;
inc(d);
until len = 0;
end;
P := @tmp;
len := d-tmp;
break;
end;
FastSetString(s,P,len);
end;
procedure CamelCase(const text: RawUTF8; var s: RawUTF8; const isWord: TSynByteSet);
begin
CamelCase(pointer(text), length(text), s, isWord);
end;
procedure GetCaptionFromPCharLen(P: PUTF8Char; out result: string);
var Temp: array[byte] of AnsiChar;
begin // "out result" parameter definition already made result := ''
if P=nil then
exit;
{$ifdef UNICODE}
// property and enumeration names are UTF-8 encoded with Delphi 2009+
UTF8DecodeToUnicodeString(Temp,UnCamelCase(@Temp,P),result);
{$else}
SetString(result,Temp,UnCamelCase(@Temp,P));
{$endif}
{$ifndef LVCL} // LVCL system.pas doesn't implement LoadResStringTranslate()
if Assigned(LoadResStringTranslate) then
LoadResStringTranslate(result);
{$endif}
end;
function GetDisplayNameFromClass(C: TClass): RawUTF8;
var DelphiName: PShortString;
TrimLeft: integer;
begin
if C=nil then begin
result := '';
exit;
end;
DelphiName := ClassNameShort(C);
TrimLeft := 0;
if DelphiName^[0]>#4 then
case PInteger(@DelphiName^[1])^ and $DFDFDFDF of
// fast case-insensitive compare
ord('T')+ord('S')shl 8+ord('Q')shl 16+ord('L')shl 24:
if (DelphiName^[0]<=#10) or
(PInteger(@DelphiName^[5])^ and $DFDFDFDF<> // fast case-insensitive compare
ord('R')+ord('E')shl 8+ord('C')shl 16+ord('O')shl 24) or
(PWord(@DelphiName^[9])^ and $DFDF<>ord('R')+ord('D')shl 8) then
TrimLeft := 4 else
TrimLeft := 10;
ord('T')+ord('S')shl 8+ord('Y')shl 16+ord('N')shl 24:
TrimLeft := 4;
end;
if (Trimleft=0) and (DelphiName^[1]='T') then
Trimleft := 1;
FastSetString(result,@DelphiName^[TrimLeft+1],ord(DelphiName^[0])-TrimLeft);
end;
function GetPublishedMethods(Instance: TObject; out Methods: TPublishedMethodInfoDynArray;
aClass: TClass): integer;
procedure AddParentsFirst(C: TClass);
type
TMethodInfo = packed record
{$ifdef FPC}
Name: PShortString;
Addr: Pointer;
{$else}
Len: Word;
Addr: Pointer;
Name: ShortString;
{$endif}
end;
var Table: {$ifdef FPC}PCardinalArray{$else}PWordArray{$endif};
M: ^TMethodInfo;
i: integer;
begin
if C=nil then
exit;
AddParentsFirst(GetClassParent(C)); // put children published methods afterward
Table := PPointer(PtrUInt(C)+PtrUInt(vmtMethodTable))^;
if Table=nil then
exit;
SetLength(Methods,result+Table^[0]);
M := @Table^[1];
for i := 1 to Table^[0] do // Table^[0] = methods count
with Methods[result] do begin
ShortStringToAnsi7String(M^.Name{$ifdef FPC}^{$endif},Name);
Method.Data := Instance;
Method.Code := M^.Addr;
{$ifdef FPC}
inc(M);
{$else}
inc(PByte(M),M^.Len);
{$endif}
inc(result);
end;
end;
begin
result := 0;
if aClass <> nil then
AddParentsFirst(aClass)
else if Instance<>nil then
AddParentsFirst(PPointer(Instance)^); // use recursion for adding
end;
function GetCaptionFromClass(C: TClass): string;
var tmp: RawUTF8;
P: PUTF8Char;
begin
if C=nil then
result := '' else begin
ToText(C,tmp);
P := pointer(tmp);
if IdemPChar(P,'TSQL') or IdemPChar(P,'TSYN') then
inc(P,4) else
if P^='T' then
inc(P);
GetCaptionFromPCharLen(P,result);
end;
end;
function GetCaptionFromEnum(aTypeInfo: pointer; aIndex: integer): string;
begin
GetCaptionFromTrimmed(GetEnumName(aTypeInfo,aIndex),result);
end;
function CharSetToCodePage(CharSet: integer): cardinal;
begin
case CharSet of
SHIFTJIS_CHARSET: result := 932;
HANGEUL_CHARSET: result := 949;
GB2312_CHARSET: result := 936;
HEBREW_CHARSET: result := 1255;
ARABIC_CHARSET: result := 1256;
GREEK_CHARSET: result := 1253;
TURKISH_CHARSET: result := 1254;
VIETNAMESE_CHARSET: result := 1258;
THAI_CHARSET: result := 874;
EASTEUROPE_CHARSET: result := 1250;
RUSSIAN_CHARSET: result := 1251;
BALTIC_CHARSET: result := 1257;
else result := CODEPAGE_US; // default is ANSI_CHARSET = iso-8859-1 = windows-1252
end;
end;
function CodePageToCharSet(CodePage: Cardinal): Integer;
begin
case CodePage of
932: result := SHIFTJIS_CHARSET;
949: result := HANGEUL_CHARSET;
936: result := GB2312_CHARSET;
1255: result := HEBREW_CHARSET;
1256: result := ARABIC_CHARSET;
1253: result := GREEK_CHARSET;
1254: result := TURKISH_CHARSET;
1258: result := VIETNAMESE_CHARSET;
874: result := THAI_CHARSET;
1250: result := EASTEUROPE_CHARSET;
1251: result := RUSSIAN_CHARSET;
1257: result := BALTIC_CHARSET;
else result := ANSI_CHARSET; // default is iso-8859-1 = windows-1252
end;
end;
function GetMimeContentTypeFromBuffer(Content: Pointer; Len: PtrInt;
const DefaultContentType: RawUTF8): RawUTF8;
begin // see http://www.garykessler.net/library/file_sigs.html for magic numbers
result := DefaultContentType;
if (Content<>nil) and (Len>4) then
case PCardinal(Content)^ of
$04034B50: result := 'application/zip'; // 50 4B 03 04
$46445025: result := 'application/pdf'; // 25 50 44 46 2D 31 2E
$21726152: result := 'application/x-rar-compressed'; // 52 61 72 21 1A 07 00
$AFBC7A37: result := 'application/x-7z-compressed'; // 37 7A BC AF 27 1C
$694C5153: result := 'application/x-sqlite3'; // SQlite format 3 = 53 51 4C 69
$75B22630: result := 'audio/x-ms-wma'; // 30 26 B2 75 8E 66
$9AC6CDD7: result := 'video/x-ms-wmv'; // D7 CD C6 9A 00 00
$474E5089: result := 'image/png'; // 89 50 4E 47 0D 0A 1A 0A
$38464947: result := 'image/gif'; // 47 49 46 38
$46464F77: result := 'application/font-woff'; // wOFF in BigEndian
$A3DF451A: result := 'video/webm'; // 1A 45 DF A3 MKV Matroska stream file
$002A4949, $2A004D4D, $2B004D4D:
result := 'image/tiff'; // 49 49 2A 00 or 4D 4D 00 2A or 4D 4D 00 2B
$46464952: if Len>16 then // RIFF
case PCardinalArray(Content)^[2] of
$50424557: result := 'image/webp';
$20495641: if PCardinalArray(Content)^[3]=$5453494C then
result := 'video/x-msvideo'; // Windows Audio Video Interleave file
end;
$E011CFD0: // Microsoft Office applications D0 CF 11 E0=DOCFILE
if Len>600 then
case PWordArray(Content)^[256] of // at offset 512
$A5EC: result := 'application/msword'; // EC A5 C1 00
$FFFD: // FD FF FF
case PByteArray(Content)^[516] of
$0E,$1C,$43: result := 'application/vnd.ms-powerpoint';
$10,$1F,$20,$22,$23,$28,$29: result := 'application/vnd.ms-excel';
end;
end;
$5367674F:
if Len>14 then // OggS
if (PCardinalArray(Content)^[1]=$00000200) and
(PCardinalArray(Content)^[2]=$00000000) and
(PWordArray(Content)^[6]=$0000) then
result := 'video/ogg';
$1C000000:
if Len>12 then
if PCardinalArray(Content)^[1]=$70797466 then // ftyp
case PCardinalArray(Content)^[2] of
$6D6F7369, // isom: ISO Base Media file (MPEG-4) v1
$3234706D: // mp42: MPEG-4 video/QuickTime file
result := 'video/mp4';
$35706733: // 3gp5: MPEG-4 video files
result := 'video/3gpp';
end;
else
case PCardinal(Content)^ and $00ffffff of
$685A42: result := 'application/bzip2'; // 42 5A 68
$088B1F: result := 'application/gzip'; // 1F 8B 08
$492049: result := 'image/tiff'; // 49 20 49
$FFD8FF: result := JPEG_CONTENT_TYPE; // FF D8 FF DB/E0/E1/E2/E3/E8
else
case PWord(Content)^ of
$4D42: result := 'image/bmp'; // 42 4D
end;
end;
end;
end;
function GetMimeContentType(Content: Pointer; Len: PtrInt;
const FileName: TFileName): RawUTF8;
begin
if FileName<>'' then begin // file extension is more precise -> check first
result := LowerCase(StringToAnsi7(ExtractFileExt(FileName)));
case PosEx(copy(result,2,4),
'png,gif,tiff,jpg,jpeg,bmp,doc,htm,html,css,js,ico,wof,txt,svg,'+
// 1 5 9 14 18 23 27 31 35 40 44 47 51 55 59
'atom,rdf,rss,webp,appc,mani,docx,xml,json,woff,ogg,ogv,mp4,m2v,'+
// 63 68 72 76 81 86 91 96 100 105 110 114 118 122
'm2p,mp3,h264,text,log,gz,webm,mkv,rar,7z') of
// 126 130 134 139 144 148 151 156 160 164
1: result := 'image/png';
5: result := 'image/gif';
9: result := 'image/tiff';
14,18: result := JPEG_CONTENT_TYPE;
23: result := 'image/bmp';
27,91: result := 'application/msword';
31,35: result := HTML_CONTENT_TYPE;
40: result := 'text/css';
44: result := 'application/javascript';
// text/javascript and application/x-javascript are obsolete (RFC 4329)
47: result := 'image/x-icon';
51,105: result := 'application/font-woff';
55,139,144: result := TEXT_CONTENT_TYPE;
59: result := 'image/svg+xml';
63,68,72,96: result := XML_CONTENT_TYPE;
76: result := 'image/webp';
81,86: result := 'text/cache-manifest';
100: result := JSON_CONTENT_TYPE_VAR;
110,114: result := 'video/ogg'; // RFC 5334
118: result := 'video/mp4'; // RFC 4337 6381
122,126: result := 'video/mp2';
130: result := 'audio/mpeg'; // RFC 3003
134: result := 'video/H264'; // RFC 6184
148: result := 'application/gzip';
151,156: result := 'video/webm';
160: result := 'application/x-rar-compressed';
164: result := 'application/x-7z-compressed';
else
result := GetMimeContentTypeFromBuffer(Content,Len,'application/'+copy(result,2,20));
end;
end else
result := GetMimeContentTypeFromBuffer(Content,Len,BINARY_CONTENT_TYPE);
end;
function GetMimeContentTypeHeader(const Content: RawByteString;
const FileName: TFileName): RawUTF8;
begin
result := HEADER_CONTENT_TYPE+
GetMimeContentType(Pointer(Content),length(Content),FileName);
end;
function IsContentCompressed(Content: Pointer; Len: PtrInt): boolean;
begin // see http://www.garykessler.net/library/file_sigs.html
result := false;
if (Content<>nil) and (Len>8) then
case PCardinal(Content)^ of
$002a4949, $2a004d4d, $2b004d4d, // 'image/tiff'
$04034b50, // 'application/zip' = 50 4B 03 04
$184d2204, // LZ4 stream format = 04 22 4D 18
$21726152, // 'application/x-rar-compressed' = 52 61 72 21 1A 07 00
$28635349, // cab = 49 53 63 28
$38464947, // 'image/gif' = 47 49 46 38
$43614c66, // FLAC = 66 4C 61 43 00 00 00 22
$4643534d, // cab = 4D 53 43 46 [MSCF]
$46464952, // avi,webp,wav = 52 49 46 46 [RIFF]
$46464f77, // 'application/font-woff' = wOFF in BigEndian
$474e5089, // 'image/png' = 89 50 4E 47 0D 0A 1A 0A
$4d5a4cff, // LZMA = FF 4C 5A 4D 41 00
$72613c21, // .ar/.deb files = '!<arch>' (assuming compressed)
$75b22630, // 'audio/x-ms-wma' = 30 26 B2 75 8E 66
$766f6f6d, // mov = 6D 6F 6F 76 [....moov]
$89a8275f, // jar = 5F 27 A8 89
$9ac6cdd7, // 'video/x-ms-wmv' = D7 CD C6 9A 00 00
$a5a5a5a5, // .mab file = MAGIC_MAB in SynLog.pas
$a5aba5a5, // .data = TSQLRESTSTORAGEINMEMORY_MAGIC in mORMot.pas
$aba51051, // .log.synlz = LOG_MAGIC in SynLog.pas
$aba5a5ab, // .dbsynlz = SQLITE3_MAGIC in SynSQLite3.pas
$afbc7a37, // 'application/x-7z-compressed' = 37 7A BC AF 27 1C
$b7010000, $ba010000, // mpeg = 00 00 01 Bx
$cececece, // jceks = CE CE CE CE
$dbeeabed, // .rpm package file
$e011cfd0: // msi = D0 CF 11 E0 A1 B1 1A E1
result := true;
else
case PCardinal(Content)^ and $00ffffff of
$088b1f, // 'application/gzip' = 1F 8B 08
$334449, // mp3 = 49 44 33 [ID3]
$492049, // 'image/tiff' = 49 20 49
$535746, // swf = 46 57 53 [FWS]
$535743, // swf = 43 57 53 [zlib]
$53575a, // zws/swf = 5A 57 53 [FWS]
$564c46, // flv = 46 4C 56 [FLV]
$685a42, // 'application/bzip2' = 42 5A 68
$ffd8ff: // JPEG_CONTENT_TYPE = FF D8 FF DB/E0/E1/E2/E3/E8
result := true;
else
case PCardinalArray(Content)^[1] of // 4 byte offset
1{TAlgoSynLZ.AlgoID}: // crc32 01 00 00 00 crc32 = Compress() header
result := PCardinalArray(Content)^[0]<>PCardinalArray(Content)^[2];
$70797466, // mp4,mov = 66 74 79 70 [33 67 70 35/4D 53 4E 56..]
$766f6f6d: // mov = 6D 6F 6F 76
result := true;
end;
end;
end;
end;
function GetJpegSize(jpeg: PAnsiChar; len: PtrInt; out Height, Width: integer): boolean;
var je: PAnsiChar;
begin // see https://en.wikipedia.org/wiki/JPEG#Syntax_and_structure
result := false;
if (jpeg=nil) or (len<100) or (PWord(jpeg)^<>$d8ff) then // SOI
exit;
je := jpeg+len-1;
inc(jpeg,2);
while jpeg<je do begin
if jpeg^<>#$ff then
exit;
inc(jpeg);
case ord(jpeg^) of
$c0..$c3,$c5..$c7,$c9..$cb,$cd..$cf: begin // SOF
Height := swap(PWord(jpeg+4)^);
Width := swap(PWord(jpeg+6)^);
result := (Height>0) and (Height<20000) and (Width>0) and (Width<20000);
exit;
end;
$d0..$d8,$01: inc(jpeg); // RST, SOI
$d9: break; // EOI
$ff: ; // padding
else inc(jpeg,swap(PWord(jpeg+1)^)+1);
end;
end;
end;
function GetJpegSize(const jpeg: TFileName; out Height, Width: integer): boolean;
var map: TMemoryMap;
begin
if map.Map(jpeg) then
try
result := GetJpegSize(map.Buffer,map.Size,Height,Width);
finally
map.UnMap;
end else
result := false;
end;
function IsHTMLContentTypeTextual(Headers: PUTF8Char): Boolean;
begin
result := ExistsIniNameValue(Headers,HEADER_CONTENT_TYPE_UPPER,
[JSON_CONTENT_TYPE_UPPER,'TEXT/','APPLICATION/XML','APPLICATION/JAVASCRIPT',
'APPLICATION/X-JAVASCRIPT','IMAGE/SVG+XML']);
end;
function MultiPartFormDataDecode(const MimeType,Body: RawUTF8;
var MultiPart: TMultiPartDynArray): boolean;
var boundary,endBoundary: RawUTF8;
i,j: integer;
P: PUTF8Char;
part: TMultiPart;
begin
result := false;
i := PosEx('boundary=',MimeType);
if i=0 then
exit;
TrimCopy(MimeType,i+9,200,boundary);
if (boundary<>'') and (boundary[1]='"') then
boundary := copy(boundary,2,length(boundary)-2); // "boundary" -> boundary
boundary := '--'+boundary;
endBoundary := boundary+'--'+#13#10;
boundary := boundary+#13#10;
i := PosEx(boundary,Body);
if i<>0 then
repeat
inc(i,length(boundary));
if i=length(body) then
exit; // reached the end
P := PUTF8Char(Pointer(Body))+i-1;
Finalize(part);
repeat
if IdemPChar(P,'CONTENT-DISPOSITION: ') then begin
inc(P,21);
if IdemPCharAndGetNextItem(P,'FORM-DATA; NAME="',part.Name,'"') then
IdemPCharAndGetNextItem(P,'; FILENAME="',part.FileName,'"') else
IdemPCharAndGetNextItem(P,'FILE; FILENAME="',part.FileName,'"')
end else
if not IdemPCharAndGetNextItem(P,'CONTENT-TYPE: ',part.ContentType) then
IdemPCharAndGetNextItem(P,'CONTENT-TRANSFER-ENCODING: ',part.Encoding);
P := GotoNextLine(P);
if P=nil then
exit;
until PWord(P)^=13+10 shl 8;
i := P-PUTF8Char(Pointer(Body))+3; // i = just after header
j := PosEx(boundary,Body,i);
if j=0 then begin
j := PosEx(endboundary,Body,i); // try last boundary
if j=0 then
exit;
end;
part.Content := copy(Body,i,j-i-2); // -2 to ignore latest #13#10
if (part.ContentType='') or (PosEx('-8',part.ContentType)>0) then begin
part.ContentType := TEXT_CONTENT_TYPE;
{$ifdef HASCODEPAGE}
SetCodePage(part.Content,CP_UTF8,false); // ensure raw field value is UTF-8
{$endif}
end;
if IdemPropNameU(part.Encoding,'base64') then
part.Content := Base64ToBin(part.Content);
// note: "quoted-printable" not yet handled here
SetLength(MultiPart,length(MultiPart)+1);
MultiPart[high(MultiPart)] := part;
result := true;
i := j;
until false;
end;
function MultiPartFormDataEncode(const MultiPart: TMultiPartDynArray;
var MultiPartContentType, MultiPartContent: RawUTF8): boolean;
var len, boundcount, filescount, i: integer;
boundaries: array of RawUTF8;
bound: RawUTF8;
W: TTextWriter;
temp: TTextWriterStackBuffer;
procedure NewBound;
var random: array[1..3] of cardinal;
begin
FillRandom(@random,3,{forcegsl=}true);
bound := BinToBase64(@random,SizeOf(Random));
SetLength(boundaries,boundcount+1);
boundaries[boundcount] := bound;
inc(boundcount);
end;
begin
result := false;
len := length(MultiPart);
if len=0 then
exit;
boundcount := 0;
filescount := 0;
W := TTextWriter.CreateOwnedStream(temp);
try
// header - see https://www.w3.org/Protocols/rfc1341/7_2_Multipart.html
NewBound;
MultiPartContentType := 'Content-Type: multipart/form-data; boundary='+bound;
for i := 0 to len-1 do
with MultiPart[i] do begin
if FileName='' then
W.Add('--%'#13#10'Content-Disposition: form-data; name="%"'#13#10+
'Content-Type: %'#13#10#13#10'%'#13#10'--%'#13#10,
[bound,Name,ContentType,Content,bound]) else begin
// if this is the first file, create the header for files
if filescount=0 then begin
if i>0 then
NewBound;
W.Add('Content-Disposition: form-data; name="files"'#13#10+
'Content-Type: multipart/mixed; boundary=%'#13#10#13#10,[bound]);
end;
inc(filescount);
W.Add('--%'#13#10'Content-Disposition: file; filename="%"'#13#10+
'Content-Type: %'#13#10,[bound,FileName,ContentType]);
if Encoding<>'' then
W.Add('Content-Transfer-Encoding: %'#13#10,[Encoding]);
W.AddCR;
W.AddString(MultiPart[i].Content);
W.Add(#13#10'--%'#13#10,[bound]);
end;
end;
// footer multipart
for i := boundcount-1 downto 0 do
W.Add('--%--'#13#10, [boundaries[i]]);
W.SetText(MultiPartContent);
result := True;
finally
W.Free;
end;
end;
function MultiPartFormDataAddFile(const FileName: TFileName;
var MultiPart: TMultiPartDynArray; const Name: RawUTF8): boolean;
var part: TMultiPart;
newlen: integer;
content: RawByteString;
begin
result := false;
content := StringFromFile(FileName);
if content='' then
exit;
newlen := length(MultiPart)+1;
if Name='' then
FormatUTF8('File%',[newlen],part.Name) else
part.Name := Name;
part.FileName := StringToUTF8(ExtractFileName(FileName));
part.ContentType := GetMimeContentType(pointer(content),length(content),FileName);
part.Encoding := 'base64';
part.Content := BinToBase64(content);
SetLength(MultiPart,newlen);
MultiPart[newlen-1] := part;
result := true;
end;
function MultiPartFormDataAddField(const FieldName, FieldValue: RawUTF8;
var MultiPart: TMultiPartDynArray): boolean;
var
part: TMultiPart;
newlen: integer;
begin
result := false;
if FieldName='' then
exit;
newlen := length(MultiPart)+1;
part.Name := FieldName;
part.ContentType := GetMimeContentTypeFromBuffer(
pointer(FieldValue),length(FieldValue),'text/plain');
part.Content := FieldValue;
SetLength(MultiPart,newlen);
MultiPart[newlen-1] := part;
result := true;
end;
function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt;
begin
result := FastLocatePUTF8CharSorted(P,R,Value,TUTF8Compare(@StrComp));
end;
function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char;
Compare: TUTF8Compare): PtrInt;
var L,i,cmp: PtrInt;
begin // fast O(log(n)) binary search
if not Assigned(Compare) or (R<0) then
result := 0 else
if Compare(P^[R],Value)<0 then // quick return if already sorted
result := R+1 else begin
L := 0;
result := -1; // return -1 if found
repeat
i := (L + R) shr 1;
cmp := Compare(P^[i],Value);
if cmp=0 then
exit;
if cmp<0 then
L := i + 1 else
R := i - 1;
until (L > R);
while (i>=0) and (Compare(P^[i],Value)>=0) do dec(i);
result := i+1; // return the index where to insert
end;
end;
function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char;
Compare: TUTF8Compare): PtrInt;
var L, cmp: PtrInt;
begin // fast O(log(n)) binary search
L := 0;
if Assigned(Compare) and (R>=0) then
repeat
result := (L+R) shr 1;
cmp := Compare(P^[result],Value);
if cmp=0 then
exit;
if cmp<0 then begin
L := result+1;
if L<=R then
continue;
break;
end;
R := result-1;
if L<=R then
continue;
break;
until false;
result := -1;
end;
function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt;
{$ifdef CPUX64} // P=rcx/rdi R=rdx/rsi Value=r8/rdx
{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif}
{$ifdef win64}
push rdi
mov rdi, P // P=rdi
{$endif}
push r12
push r13
xor r9, r9 // L=r9
test R, R
jl @err
test Value, Value
jz @void
mov cl, byte ptr[Value] // to check first char (likely diverse)
@s: lea rax, qword ptr[r9 + R]
shr rax, 1
lea r12, qword ptr[rax - 1] // branchless main loop
lea r13, qword ptr[rax + 1]
mov r10, qword ptr[rdi + rax * 8]
test r10, r10
jz @lt
cmp cl, byte ptr[r10]
je @eq
cmovc R, r12
cmovnc r9, r13
@nxt: cmp r9, R
jle @s
@err: or rax, -1
@found: pop r13
pop r12
{$ifdef win64}
pop rdi
{$endif}
ret
@lt: mov r9, r13 // very unlikely P[rax]=nil
jmp @nxt
@eq: mov r11, Value
@sub: mov cl, byte ptr[r10]
inc r10
inc r11
test cl, cl
jz @found
mov cl, byte ptr[r11]
cmp cl, byte ptr[r10]
je @sub
mov cl, byte ptr[Value] // reset first char
cmovc R, r12
cmovnc r9, r13
cmp r9, R
jle @s
jmp @err
@void: or rax, -1
cmp qword ptr[P], 0
cmove rax, Value
jmp @found
end;
{$else}
var L: PtrInt;
c: byte;
piv,val: PByte;
begin // fast O(log(n)) binary search using inlined StrCompFast()
if R>=0 then
if Value<>nil then begin
L := 0;
repeat
result := (L+R) shr 1;
piv := pointer(P^[result]);
if piv<>nil then begin
val := pointer(Value);
c := piv^;
if c=val^ then
repeat
if c=0 then
exit; // StrComp(P^[result],Value)=0
inc(piv);
inc(val);
c := piv^;
until c<>val^;
if c>val^ then begin
R := result-1; // StrComp(P^[result],Value)>0
if L<=R then
continue;
break;
end;
end;
L := result+1; // StrComp(P^[result],Value)<0
if L<=R then
continue;
break;
until false;
end else
if P^[0]=nil then begin // '' should be in lowest P[] slot
result := 0;
exit;
end;
result := -1;
end;
{$endif CPUX64}
function FastFindUpperPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt;
Value: PUTF8Char; ValueLen: PtrInt): PtrInt;
var tmp: array[byte] of AnsiChar;
begin
UpperCopy255Buf(@tmp,Value,ValueLen)^ := #0;
result := FastFindPUTF8CharSorted(P,R,@tmp);
end;
function FastFindIndexedPUTF8Char(P: PPUTF8CharArray; R: PtrInt;
var SortedIndexes: TCardinalDynArray; Value: PUTF8Char;
ItemComp: TUTF8Compare): PtrInt;
var L, cmp: PtrInt;
begin // fast O(log(n)) binary search
L := 0;
if 0<=R then
repeat
result := (L + R) shr 1;
cmp := ItemComp(P^[SortedIndexes[result]],Value);
if cmp=0 then begin
result := SortedIndexes[result];
exit;
end;
if cmp<0 then begin
L := result+1;
if L<=R then
continue;
break;
end;
R := result-1;
if L<=R then
continue;
break;
until false;
result := -1;
end;
function AddSortedRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer;
const Value: RawUTF8; CoValues: PIntegerDynArray; ForcedIndex: PtrInt;
Compare: TUTF8Compare): PtrInt;
var n: PtrInt;
begin
if ForcedIndex>=0 then
result := ForcedIndex else begin
if not Assigned(Compare) then
Compare := @StrComp;
result := FastLocatePUTF8CharSorted(pointer(Values),ValuesCount-1,pointer(Value),Compare);
if result<0 then
exit; // Value exists -> fails
end;
n := Length(Values);
if ValuesCount=n then begin
n := NextGrow(n);
SetLength(Values,n);
if CoValues<>nil then
SetLength(CoValues^,n);
end;
n := ValuesCount;
if 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 = object
Values: PPointerArray;
Compare: TUTF8Compare;
CoValues: PIntegerArray;
pivot: pointer;
procedure Sort(L,R: PtrInt);
end;
procedure TQuickSortRawUTF8.Sort(L, R: PtrInt);
var I, J, P: PtrInt;
Tmp: Pointer;
TmpInt: integer;
begin
if 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 J - L < R - I then begin // use recursion only for smaller range
if L < J then
Sort(L, J);
L := I;
end else begin
if I < R then
Sort(I, R);
R := J;
end;
until L >= R;
end;
procedure QuickSortRawUTF8(var Values: TRawUTF8DynArray; ValuesCount: integer;
CoValues: PIntegerDynArray; Compare: TUTF8Compare);
var QS: TQuickSortRawUTF8;
begin
QS.Values := pointer(Values);
if Assigned(Compare) then
QS.Compare := Compare else
QS.Compare := @StrComp;
if CoValues=nil then
QS.CoValues := nil else
QS.CoValues := pointer(CoValues^);
QS.Sort(0,ValuesCount-1);
end;
function DeleteRawUTF8(var Values: TRawUTF8DynArray; Index: integer): boolean;
var n: integer;
begin
n := length(Values);
if cardinal(Index)>=cardinal(n) then
result := false else begin
dec(n);
if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then
DynArrayMakeUnique(@Values,TypeInfo(TRawUTF8DynArray));
Values[Index] := ''; // avoid GPF
if n>Index then begin
MoveFast(pointer(Values[Index+1]),pointer(Values[Index]),(n-Index)*SizeOf(pointer));
PtrUInt(Values[n]) := 0; // avoid GPF
end;
SetLength(Values,n);
result := true;
end;
end;
function DeleteRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer;
Index: integer; CoValues: PIntegerDynArray): boolean;
var n: integer;
begin
n := ValuesCount;
if cardinal(Index)>=cardinal(n) then
result := false else begin
dec(n);
ValuesCount := n;
if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then
DynArrayMakeUnique(@Values,TypeInfo(TRawUTF8DynArray));
Values[Index] := ''; // avoid GPF
dec(n,Index);
if n>0 then begin
if CoValues<>nil then
MoveFast(CoValues^[Index+1],CoValues^[Index],n*SizeOf(Integer));
MoveFast(pointer(Values[Index+1]),pointer(Values[Index]),n*SizeOf(pointer));
PtrUInt(Values[ValuesCount]) := 0; // avoid GPF
end;
result := true;
end;
end;
function ToText(const aIntelCPUFeatures: TIntelCpuFeatures; const Sep: RawUTF8): RawUTF8;
var f: TIntelCpuFeature;
List: PShortString;
MaxValue: integer;
begin
result := '';
List := GetEnumInfo(TypeInfo(TIntelCpuFeature),MaxValue);
if List<>nil then
for f := low(f) to high(f) do begin
if (f in aIntelCPUFeatures) and (List^[3]<>'_') then begin
if result<>'' then
result := result+Sep;
result := result+RawUTF8(copy(List^,3,10));
end;
inc(PByte(List),PByte(List)^+1); // next
end;
end;
{$ifdef MSWINDOWS}
// wrapper around some low-level Windows-specific API
{$ifdef DELPHI6OROLDER}
function GetFileVersion(const FileName: TFileName): cardinal;
var Size, Size2: DWord;
Pt: Pointer;
Info: ^TVSFixedFileInfo;
tmp: TFileName;
begin
result := cardinal(-1);
if FileName='' then
exit;
// GetFileVersionInfo modifies the filename parameter data while parsing
// Copy the string const into a local variable to create a writeable copy
SetString(tmp,PChar(FileName),length(FileName));
Size := GetFileVersionInfoSize(pointer(tmp), Size2);
if Size>0 then begin
GetMem(Pt, Size);
try
GetFileVersionInfo(pointer(FileName), 0, Size, Pt);
if VerQueryValue(Pt, '\', pointer(Info), Size2) then
result := Info^.dwFileVersionMS;
finally
Freemem(Pt);
end;
end;
end;
{$endif DELPHI6OROLDER}
function WndProcMethod(Hwnd: HWND; Msg,wParam,lParam: integer): integer; stdcall;
var obj: TObject;
dsp: TMessage;
begin
{$ifdef CPU64}
obj := pointer(GetWindowLongPtr(HWnd,GWLP_USERDATA));
{$else}
obj := pointer(GetWindowLong(HWnd,GWL_USERDATA)); // faster than GetProp()
{$endif CPU64}
if not Assigned(obj) then
result := DefWindowProc(HWnd,Msg,wParam,lParam) else begin
dsp.msg := Msg;
dsp.wParam := WParam;
dsp.lParam := lParam;
dsp.result := 0;
obj.Dispatch(dsp);
result := dsp.result;
end;
end;
function CreateInternalWindow(const aWindowName: string; aObject: TObject): HWND;
var TempClass: TWndClass;
begin
result := 0;
if GetClassInfo(HInstance, pointer(aWindowName), TempClass) then
exit; // class name already registered -> fail
FillCharFast(TempClass,SizeOf(TempClass),0);
TempClass.hInstance := HInstance;
TempClass.lpfnWndProc := @DefWindowProc;
TempClass.lpszClassName := pointer(aWindowName);
Windows.RegisterClass(TempClass);
result := CreateWindowEx(WS_EX_TOOLWINDOW, pointer(aWindowName),
'', WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil);
if result=0 then
exit; // impossible to create window -> fail
{$ifdef CPU64}
SetWindowLongPtr(result,GWLP_USERDATA,PtrInt(aObject));
SetWindowLongPtr(result,GWLP_WNDPROC,PtrInt(@WndProcMethod));
{$else}
SetWindowLong(result,GWL_USERDATA,PtrInt(aObject)); // faster than SetProp()
SetWindowLong(result,GWL_WNDPROC,PtrInt(@WndProcMethod));
{$endif CPU64}
end;
function ReleaseInternalWindow(var aWindowName: string; var aWindow: HWND): boolean;
begin
if (aWindow<>0) and (aWindowName<>'') then begin
{$ifdef CPU64}
SetWindowLongPtr(aWindow,GWLP_WNDPROC,PtrInt(@DefWindowProc));
{$else}
SetWindowLong(aWindow,GWL_WNDPROC,PtrInt(@DefWindowProc));
{$endif CPU64}
DestroyWindow(aWindow);
Windows.UnregisterClass(pointer(aWindowName),HInstance);
aWindow := 0;
aWindowName := '';
result := true;
end else
result := false;
end;
var
LastAppUserModelID: string;
function SetAppUserModelID(const AppUserModelID: string): boolean;
var shell32: THandle;
id: SynUnicode;
SetCurrentProcessExplicitAppUserModelID: function(appID: PWidechar): HResult; stdcall;
begin
if AppUserModelID=LastAppUserModelID then begin
result := true;
exit; // nothing to set
end;
result := false;
shell32 := GetModuleHandle('shell32.dll');
if shell32=0 then
exit;
SetCurrentProcessExplicitAppUserModelID := GetProcAddress(
shell32,'SetCurrentProcessExplicitAppUserModelID');
if not Assigned(SetCurrentProcessExplicitAppUserModelID) then
exit; // API available since Windows Seven / Server 2008 R2
StringToSynUnicode(AppUserModelID,id);
if Pos('.',AppUserModelID)=0 then
id := id+'.'+id; // at least CompanyName.ProductName
if SetCurrentProcessExplicitAppUserModelID(pointer(id))<>S_OK then
exit;
result := true;
LastAppUserModelID := AppUserModelID;
end;
{$endif MSWINDOWS}
{ TFileVersion }
constructor TFileVersion.Create(const aFileName: TFileName;
aMajor,aMinor,aRelease,aBuild: integer);
var M,D: word;
{$ifdef MSWINDOWS}
Size, Size2: DWord;
Pt, StrPt, StrValPt: Pointer;
LanguageInfo: RawUTF8;
Info: ^TVSFixedFileInfo;
FileTime: TFILETIME;
SystemTime: TSYSTEMTIME;
tmp: TFileName;
function ReadResourceByName(const From: RawUTF8): RawUTF8;
var sz: DWord;
begin
VerQueryValueA(Pt,PAnsiChar('\StringFileInfo\'+LanguageInfo+'\'+From),StrValPt,sz);
if sz>0 then
FastSetString(Result,StrValPt,sz)
end;
{$else}
{$ifdef FPCUSEVERSIONINFO}
VI: TVersionInfo;
LanguageInfo: String;
TI, I: Integer;
{$endif}
{$endif MSWINDOWS}
begin
fFileName := aFileName;
{$ifdef MSWINDOWS}
if aFileName<>'' then begin
// GetFileVersionInfo modifies the filename parameter data while parsing.
// Copy the string const into a local variable to create a writeable copy.
SetString(tmp,PChar(aFileName),length(aFileName));
Size := GetFileVersionInfoSize(pointer(tmp), Size2);
if Size>0 then begin
GetMem(Pt, Size);
try
GetFileVersionInfo(pointer(aFileName), 0, Size, Pt);
VerQueryValue(Pt, '\', pointer(Info), Size2);
with Info^ do begin
if Version32=0 then begin
aMajor := dwFileVersionMS shr 16;
aMinor := word(dwFileVersionMS);
aRelease := dwFileVersionLS shr 16;
end;
aBuild := word(dwFileVersionLS);
if (dwFileDateLS<>0) and (dwFileDateMS<>0) then begin
FileTime.dwLowDateTime:= dwFileDateLS; // built date from version info
FileTime.dwHighDateTime:= dwFileDateMS;
FileTimeToSystemTime(FileTime, SystemTime);
fBuildDateTime := EncodeDate(
SystemTime.wYear,SystemTime.wMonth,SystemTime.wDay);
end;
end;
VerQueryValue(Pt, '\VarFileInfo\Translation', StrPt, Size2);
if Size2 >= 4 then begin
LanguageInfo := BinToHexDisplay(PAnsiChar(StrPt), 2) + BinToHexDisplay(PAnsiChar(StrPt)+2, 2);
CompanyName := ReadResourceByName('CompanyName');
FileDescription := ReadResourceByName('FileDescription');
FileVersion := ReadResourceByName('FileVersion');
InternalName := ReadResourceByName('InternalName');
LegalCopyright := ReadResourceByName('LegalCopyright');
OriginalFilename := ReadResourceByName('OriginalFilename');
ProductName := ReadResourceByName('ProductName');
ProductVersion := ReadResourceByName('ProductVersion');
Comments := ReadResourceByName('Comments');
end
finally
Freemem(Pt);
end;
end;
end;
{$else MSWINDOWS}
{$ifdef FPCUSEVERSIONINFO} // FPC 3.0+ if enabled in Synopse.inc / project options
if aFileName<>'' then
try
VI := TVersionInfo.Create;
try
if (aFileName<>ExeVersion.ProgramFileName) and (aFileName<>ParamStr(0)) then
VI.Load(aFileName) else
VI.Load(HInstance); // load info for currently running program
aMajor := VI.FixedInfo.FileVersion[0];
aMinor := VI.FixedInfo.FileVersion[1];
aRelease := VI.FixedInfo.FileVersion[2];
aBuild := VI.FixedInfo.FileVersion[3];
//fBuildDateTime := TDateTime(VI.FixedInfo.FileDate); << need to find out how to convert this before uncommenting
// detect translation.
if VI.VarFileInfo.Count>0 then
with VI.VarFileInfo.Items[0] do
LanguageInfo := Format('%.4x%.4x',[language,codepage]);
if LanguageInfo='' then begin
// take first language
Ti := 0;
if VI.StringFileInfo.Count>0 then
LanguageInfo := VI.StringFileInfo.Items[0].Name
end else begin
// look for index of language
TI := VI.StringFileInfo.Count-1;
while (TI>=0) and (CompareText(VI.StringFileInfo.Items[TI].Name,LanguageInfo)<>0) do
dec(TI);
if (TI < 0) then begin
TI := 0; // revert to first translation
LanguageInfo := VI.StringFileInfo.Items[TI].Name;
end;
end;
with VI.StringFileInfo.Items[TI] do begin
CompanyName := Values['CompanyName'];
FileDescription := Values['FileDescription'];
FileVersion := Values['FileVersion'];
InternalName := Values['InternalName'];
LegalCopyright := Values['LegalCopyright'];
OriginalFilename := Values['OriginalFilename'];
ProductName := Values['ProductName'];
ProductVersion := Values['ProductVersion'];
Comments := Values['Comments'];
end;
finally
VI.Free;
end;
except
// just ignore if version information resource is missing
end;
{$endif FPCUSEVERSIONINFO}
{$endif MSWINDOWS}
SetVersion(aMajor,aMinor,aRelease,aBuild);
if fBuildDateTime=0 then // get build date from file age
fBuildDateTime := FileAgeToDateTime(aFileName);
if fBuildDateTime<>0 then
DecodeDate(fBuildDateTime,BuildYear,M,D);
end;
function TFileVersion.Version32: integer;
begin
result := Major shl 16+Minor shl 8+Release;
end;
procedure TFileVersion.SetVersion(aMajor,aMinor,aRelease,aBuild: integer);
begin
Major := aMajor;
Minor := aMinor;
Release := aRelease;
Build := aBuild;
Main := IntToString(Major)+'.'+IntToString(Minor);
fDetailed := Main+ '.'+IntToString(Release)+'.'+IntToString(Build);
end;
function TFileVersion.BuildDateTimeString: string;
begin
DateTimeToIso8601StringVar(fBuildDateTime,' ',result);
end;
function TFileVersion.DetailedOrVoid: string;
begin
if (self=nil) or (Major or Minor or Release or Build=0) then
result := '' else
result := fDetailed;
end;
function TFileVersion.VersionInfo: RawUTF8;
begin
FormatUTF8('% % (%)',[ExtractFileName(fFileName),DetailedOrVoid,BuildDateTimeString],result);
end;
function TFileVersion.UserAgent: RawUTF8;
begin
if self=nil then
result := '' else
FormatUTF8('%/%%',[GetFileNameWithoutExt(ExtractFileName(fFileName)),
DetailedOrVoid,OS_INITIAL[OS_KIND]],result);
{$ifdef MSWINDOWS}
if OSVersion in WINDOWS_32 then
result := result+'32';
{$endif MSWINDOWS}
end;
class function TFileVersion.GetVersionInfo(const aFileName: TFileName): RawUTF8;
begin
with Create(aFileName,0,0,0,0) do
try
result := VersionInfo;
finally
Free;
end;
end;
procedure SetExecutableVersion(const aVersionText: RawUTF8);
var P: PUTF8Char;
i: integer;
ver: array[0..3] of integer;
begin
P := pointer(aVersionText);
for i := 0 to 3 do
ver[i] := GetNextItemCardinal(P,'.');
SetExecutableVersion(ver[0],ver[1],ver[2],ver[3]);
end;
procedure SetExecutableVersion(aMajor,aMinor,aRelease,aBuild: integer);
var {$ifdef MSWINDOWS}
tmp: array[byte] of WideChar;
tmpsize: cardinal;
{$else}
tmp: string;
{$endif}
begin
with ExeVersion do begin
if Version=nil then begin
{$ifdef MSWINDOWS}
ProgramFileName := paramstr(0);
{$else}
ProgramFileName := GetModuleName(HInstance);
if ProgramFileName='' then
ProgramFileName := ExpandFileName(paramstr(0));
{$endif MSWINDOWS}
ProgramFilePath := ExtractFilePath(ProgramFileName);
if IsLibrary then
InstanceFileName := GetModuleName(HInstance) else
InstanceFileName := ProgramFileName;
ProgramName := StringToUTF8(GetFileNameWithoutExt(ExtractFileName(ProgramFileName)));
{$ifdef MSWINDOWS}
tmpsize := SizeOf(tmp);
GetComputerNameW(tmp,tmpsize);
RawUnicodeToUtf8(@tmp,StrLenW(tmp),Host);
tmpsize := SizeOf(tmp);
GetUserNameW(tmp,tmpsize);
RawUnicodeToUtf8(@tmp,StrLenW(tmp),User);
{$else}
StringToUTF8(GetHostName,Host);
if Host='' then
StringToUTF8(GetEnvironmentVariable('HOSTNAME'),Host);
tmp := GetEnvironmentVariable('LOGNAME'); // POSIX
if tmp='' then
tmp := GetEnvironmentVariable('USER');
{$ifdef KYLIX3}
if tmp='' then
User := LibC.getpwuid(LibC.getuid)^.pw_name else
{$endif}
StringToUTF8(tmp,User);
{$endif MSWINDOWS}
if Host='' then
Host := 'unknown';
if User='' then
User := 'unknown';
GarbageCollectorFreeAndNil(Version,
TFileVersion.Create(InstanceFileName,aMajor,aMinor,aRelease,aBuild));
end else
Version.SetVersion(aMajor,aMinor,aRelease,aBuild);
FormatUTF8('% % (%)',[ProgramFileName,Version.Detailed,
DateTimeToIso8601(Version.BuildDateTime,True,' ')],ProgramFullSpec);
Hash.c0 := Version.Version32;
{$ifdef CPUINTEL}
Hash.c0 := crc32c(Hash.c0,@CpuFeatures,SizeOf(CpuFeatures));
{$endif}
Hash.c0 := crc32c(Hash.c0,pointer(Host),length(Host));
Hash.c1 := crc32c(Hash.c0,pointer(User),length(User));
Hash.c2 := crc32c(Hash.c1,pointer(ProgramFullSpec),length(ProgramFullSpec));
Hash.c3 := crc32c(Hash.c2,pointer(InstanceFileName),length(InstanceFileName));
end;
end;
{$ifdef MSWINDOWS}
// avoid unneeded reference to ShlObj.pas
function SHGetFolderPath(hwnd: HWND; csidl: Integer; hToken: THandle;
dwFlags: DWord; pszPath: PChar): HRESULT; stdcall; external 'SHFolder.dll'
name {$ifdef UNICODE}'SHGetFolderPathW'{$else}'SHGetFolderPathA'{$endif};
var
_SystemPath: array[TSystemPath] of TFileName;
function GetSystemPath(kind: TSystemPath): TFileName;
const
CSIDL_PERSONAL = $0005;
CSIDL_LOCAL_APPDATA = $001C; // local non roaming user folder
CSIDL_COMMON_APPDATA = $0023;
CSIDL_COMMON_DOCUMENTS = $002E;
CSIDL: array[TSystemPath] of integer = (
// spCommonData, spUserData, spCommonDocuments
CSIDL_COMMON_APPDATA, CSIDL_LOCAL_APPDATA, CSIDL_COMMON_DOCUMENTS,
// spUserDocuments, spTempFolder, spLog
CSIDL_PERSONAL, 0, CSIDL_LOCAL_APPDATA);
ENV: array[TSystemPath] of TFileName = (
'ALLUSERSAPPDATA', 'LOCALAPPDATA', '', '', 'TEMP', 'LOCALAPPDATA');
var tmp: array[0..MAX_PATH] of char;
begin
if _SystemPath[kind]='' then
if (kind=spLog) and IsDirectoryWritable(ExeVersion.ProgramFilePath) then
_SystemPath[kind] := EnsureDirectoryExists(ExeVersion.ProgramFilePath+'log') else
if (CSIDL[kind]<>0) and (SHGetFolderPath(0,CSIDL[kind],0,0,@tmp)=S_OK) then
_SystemPath[kind] := IncludeTrailingPathDelimiter(tmp) else begin
_SystemPath[kind] := GetEnvironmentVariable(ENV[kind]);
if _SystemPath[kind]='' then
_SystemPath[kind] := GetEnvironmentVariable('APPDATA');
_SystemPath[kind] := IncludeTrailingPathDelimiter(_SystemPath[kind]);
end;
result := _SystemPath[kind];
end;
{$else MSWINDOWS}
var
_HomePath, _TempPath, _UserPath, _LogPath: TFileName;
function GetSystemPath(kind: TSystemPath): TFileName;
begin
case kind of
spLog: begin
if _LogPath='' then
if IsDirectoryWritable('/var/log') then
_LogPath := '/var/log/' else // may not be writable by not root on POSIX
if IsDirectoryWritable(ExeVersion.ProgramFilePath) then
_LogPath := ExeVersion.ProgramFilePath else
_LogPath := GetSystemPath(spUserData);
result := _LogPath;
end;
spUserData: begin
if _UserPath='' then begin // ~/.cache/appname
_UserPath := GetEnvironmentVariable('XDG_CACHE_HOME');
if (_UserPath='') or not IsDirectoryWritable(_UserPath) then
_UserPath := EnsureDirectoryExists(GetSystemPath(spUserDocuments)+'.cache');
_UserPath := EnsureDirectoryExists(_UserPath+UTF8ToString(ExeVersion.ProgramName));
end;
result := _UserPath;
end;
spTempFolder: begin
if _TempPath='' then begin
_TempPath := GetEnvironmentVariable('TMPDIR'); // POSIX
if _TempPath='' then
_TempPath := GetEnvironmentVariable('TMP');
if _TempPath='' then
if DirectoryExists('/tmp') then
_TempPath := '/tmp' else
_TempPath := '/var/tmp';
_TempPath := IncludeTrailingPathDelimiter(_TempPath);
end;
result := _TempPath;
end else begin
if _HomePath='' then // POSIX requires a value for $HOME
_HomePath := IncludeTrailingPathDelimiter(GetEnvironmentVariable('HOME'));
result := _HomePath;
end;
end;
end;
{$endif MSWINDOWS}
procedure PatchCode(Old,New: pointer; Size: integer; Backup: pointer;
LeaveUnprotected: boolean);
{$ifdef MSWINDOWS}
var RestoreProtection, Ignore: DWORD;
i: integer;
begin
if VirtualProtect(Old, Size, PAGE_EXECUTE_READWRITE, RestoreProtection) then
begin
if Backup<>nil then
for i := 0 to Size-1 do // do not use Move() here
PByteArray(Backup)^[i] := PByteArray(Old)^[i];
for i := 0 to Size-1 do // do not use Move() here
PByteArray(Old)^[i] := PByteArray(New)^[i];
if not LeaveUnprotected then
VirtualProtect(Old, Size, RestoreProtection, Ignore);
FlushInstructionCache(GetCurrentProcess, Old, Size);
if not CompareMemFixed(Old,New,Size) then
raise ESynException.Create('PatchCode?');
end;
end;
{$else}
var PageSize: PtrUInt;
AlignedAddr: pointer;
i: PtrInt;
ProtectedResult: boolean;
ProtectedMemory: boolean;
begin
if Backup<>nil then
for i := 0 to Size-1 do // do not use Move() here
PByteArray(Backup)^[i] := PByteArray(Old)^[i];
PageSize := SystemInfo.dwPageSize;
AlignedAddr := Pointer((PtrUInt(Old) DIV SystemInfo.dwPageSize) * SystemInfo.dwPageSize);
while PtrUInt(Old)+PtrUInt(Size)>=PtrUInt(AlignedAddr)+PageSize do
Inc(PageSize,SystemInfo.dwPageSize);
ProtectedResult := SynMProtect(AlignedAddr,PageSize,PROT_READ or PROT_WRITE or PROT_EXEC) = 0;
ProtectedMemory := not ProtectedResult;
if ProtectedMemory then
ProtectedResult := SynMProtect(AlignedAddr,PageSize,PROT_READ or PROT_WRITE) = 0;
if ProtectedResult then
try
for i := 0 to Size-1 do // do not use Move() here
PByteArray(Old)^[i] := PByteArray(New)^[i];
if not LeaveUnprotected and ProtectedMemory then
SynMProtect(AlignedAddr,PageSize,PROT_READ or PROT_EXEC);
except
end;
end;
{$endif MSWINDOWS}
procedure PatchCodePtrUInt(Code: PPtrUInt; Value: PtrUInt;
LeaveUnprotected: boolean);
begin
PatchCode(Code,@Value,SizeOf(Code^),nil,LeaveUnprotected);
end;
{$ifdef CPUINTEL}
procedure RedirectCode(Func, RedirectFunc: Pointer; Backup: PPatchCode);
var NewJump: packed record
Code: byte; // $e9 = jmp {relative}
Distance: integer; // relative jump is 32-bit even on CPU64
end;
begin
if (Func=nil) or (RedirectFunc=nil) then
exit; // nothing to redirect to
assert(SizeOf(TPatchCode)=SizeOf(NewJump));
NewJump.Code := $e9;
NewJump.Distance := integer(PtrUInt(RedirectFunc)-PtrUInt(Func)-SizeOf(NewJump));
PatchCode(Func,@NewJump,SizeOf(NewJump),Backup);
{$ifndef LVCL}
assert(pByte(Func)^=$e9);
{$endif}
end;
procedure RedirectCodeRestore(Func: pointer; const Backup: TPatchCode);
begin
PatchCode(Func,@Backup,SizeOf(TPatchCode));
end;
{$endif CPUINTEL}
{$ifndef LVCL}
{$ifndef FPC}
{$ifndef UNICODE}
const
MemoryDelta = $8000; // 32 KB granularity (must be a power of 2)
function THeapMemoryStream.Realloc(var NewCapacity: longint): Pointer;
// allocates memory from Delphi heap (FastMM4/SynScaleMM) and not windows.Global*()
// and uses bigger growing size -> a lot faster
var i: PtrInt;
begin
if NewCapacity>0 then begin
i := Seek(0,soFromCurrent); // no direct access to fSize -> use Seek() trick
if NewCapacity=Seek(0,soFromEnd) then begin // avoid ReallocMem() if just truncate
result := Memory;
Seek(i,soBeginning);
exit;
end;
NewCapacity := (NewCapacity + (MemoryDelta - 1)) and not (MemoryDelta - 1);
Seek(i,soBeginning);
end;
Result := Memory;
if NewCapacity <> Capacity then begin
if NewCapacity = 0 then begin
FreeMem(Memory);
Result := nil;
end else begin
if Capacity = 0 then
GetMem(Result, NewCapacity) else
if NewCapacity > Capacity then // only realloc if necessary (grow up)
ReallocMem(Result, NewCapacity) else
NewCapacity := Capacity; // same capacity as before
if Result = nil then
raise EStreamError.Create('THeapMemoryStream'); // memory allocation bug
end;
end;
end;
{$endif UNICODE}
{$endif FPC}
{$endif LVCL}
{ TSortedWordArray }
function FastLocateWordSorted(P: PWordArray; R: integer; Value: word): PtrInt;
var L,cmp: PtrInt;
begin
if R<0 then
result := 0 else begin
L := 0;
repeat
result := (L + R) shr 1;
cmp := P^[result]-Value;
if cmp=0 then begin
result := -result-1; // return -(foundindex+1) if already exists
exit;
end;
if cmp<0 then
L := result + 1 else
R := result - 1;
until (L > R);
while (result>=0) and (P^[result]>=Value) do dec(result);
result := result+1; // return the index where to insert
end;
end;
function FastFindWordSorted(P: PWordArray; R: PtrInt; Value: Word): PtrInt;
{$ifdef CPUX64} // P=rcx/rdi R=rdx/rsi Value=r8w/dx
{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif}
{$ifdef win64}
push rdi
mov rdi, P // rdi=P
{$endif}
xor r9, r9 // r9=L rax=result
test R, R
jl @ko
{$ifdef FPC} align 8 {$else} .align 8 {$endif}
@s: lea rax, [r9 + R]
shr rax, 1
lea r10, qword ptr[rax - 1] // branchless loop
lea r11, qword ptr[rax + 1]
movzx ecx, word ptr[rdi + rax * 2]
{$ifdef win64}
cmp ecx, r8d
{$else}
cmp ecx, edx // 'cmp cx,Value' is silently rejected by Darwin asm
{$endif win64}
je @ok
cmovg R, r10
cmovl r9, r11
cmp r9, R
jle @s
@ko: or rax, -1
@ok: {$ifdef win64}
pop rdi
{$endif}
end;
{$else}
var L: PtrInt;
cmp: integer;
begin
L := 0;
if 0<=R then
repeat
result := (L + R) shr 1;
cmp := P^[result]-Value;
if cmp=0 then
exit;
if cmp<0 then begin
L := result+1;
if L<=R then
continue;
break;
end;
R := result-1;
if L<=R then
continue;
break;
until false;
result := -1
end;
{$endif CPUX64}
function TSortedWordArray.Add(aValue: Word): PtrInt;
begin
result := Count; // optimistic check of perfectly increasing aValue
if (result>0) and (aValue<=Values[result-1]) then
result := FastLocateWordSorted(pointer(Values),result-1,aValue);
if result<0 then // aValue already exists in Values[] -> fails
exit;
if Count=length(Values) then
SetLength(Values,NextGrow(Count));
if result<Count then
MoveFast(Values[result],Values[result+1],(Count-result)*SizeOf(word)) else
result := Count;
Values[result] := aValue;
inc(Count);
end;
function TSortedWordArray.IndexOf(aValue: Word): PtrInt;
begin
result := FastFindWordSorted(pointer(Values),Count-1,aValue);
end;
procedure QuickSortCompare(const OnCompare: TOnValueGreater;
Index: 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 := Index[P];
while OnCompare(pivot,Index[I]) do inc(I);
while OnCompare(Index[J],pivot) do dec(J);
if I <= J then begin
tmp := Index[J]; Index[J] := Index[I]; Index[I] := tmp;
if P = I then P := J else if P = J then P := I;
inc(I); dec(J);
end;
until I > J;
if J - L < R - I then begin // use recursion only for smaller range
if L < J then
QuickSortCompare(OnCompare, Index, L, J);
L := I;
end else begin
if I < R then
QuickSortCompare(OnCompare, Index, I, R);
R := J;
end;
until L >= R;
end;
procedure Exchg32(var A,B: integer); {$ifdef HASINLINE}inline;{$endif}
var tmp: integer;
begin
tmp := A;
A := B;
B := tmp;
end;
function MedianQuickSelectInteger(Values: PIntegerArray; n: integer): integer;
var low, high, median, middle, ll, hh: PtrInt;
begin
if n=0 then begin
result := 0;
exit;
end;
if n=1 then begin
result := Values[0];
exit;
end;
low := 0;
high := n-1;
median := high shr 1;
repeat
if high<=low then begin // one item left
result := Values[median];
exit;
end;
if high=low+1 then begin // two items -> return the smallest (not average)
if Values[low]>Values[high] then
Exchg32(Values[low],Values[high]);
result := Values[median];
exit;
end;
// find median of low, middle and high items; swap into position low
middle := (low+high) shr 1;
if Values[middle]>Values[high] then
Exchg32(Values[middle],Values[high]);
if Values[low]>Values[high] then
Exchg32(Values[low],Values[high]);
if Values[middle]>Values[low] then
Exchg32(Values[middle],Values[low]);
// swap low item (now in position middle) into position (low+1)
Exchg32(Values[middle],Values[low+1]);
// nibble from each end towards middle, swapping items when stuck
ll := low+1;
hh := high;
repeat
repeat
inc(ll);
until not (Values[low]>Values[ll]);
repeat
dec(hh);
until not (Values[hh]>Values[low]);
if hh<ll then
break;
Exchg32(Values[ll],Values[hh]);
until false;
// swap middle item (in position low) back into correct position
Exchg32(Values[low],Values[hh]);
// next active partition
if hh<=median then
low := ll;
if hh>=median then
high := hh-1;
until false;
end;
function MedianQuickSelect(const OnCompare: TOnValueGreater; n: integer;
var TempBuffer: TSynTempBuffer): integer;
var low, high, middle, median, ll, hh: PtrInt;
tmp: integer;
ndx: PIntegerArray;
begin
if n<=1 then begin
TempBuffer.buf := nil; // avoid GPF in TempBuffer.Done
result := 0;
exit;
end;
low := 0;
high := n-1;
ndx := TempBuffer.InitIncreasing(n*4); // no heap alloacation until n>1024
median := high shr 1;
repeat
if high<=low then begin // one item left
result := ndx[median];
TempBuffer.Done;
exit;
end;
if high=low+1 then begin // two items -> return the smallest (not average)
if OnCompare(ndx[low],ndx[high]) then
Exchg32(ndx[low],ndx[high]);
result := ndx[median];
TempBuffer.Done;
exit;
end;
// find median of low, middle and high items; swap into position low
middle := (low+high) shr 1;
if OnCompare(ndx[middle],ndx[high]) then
Exchg32(ndx[middle],ndx[high]);
if OnCompare(ndx[low],ndx[high]) then
Exchg32(ndx[low],ndx[high]);
if OnCompare(ndx[middle],ndx[low]) then
Exchg32(ndx[middle],ndx[low]);
// swap low item (now in position middle) into position (low+1)
Exchg32(ndx[middle],ndx[low+1]);
// nibble from each end towards middle, swapping items when stuck
ll := low+1;
hh := high;
repeat
tmp := ndx[low];
repeat
inc(ll);
until not OnCompare(tmp,ndx[ll]);
repeat
dec(hh);
until not OnCompare(ndx[hh],tmp);
if hh<ll then
break;
tmp := ndx[ll]; ndx[ll] := ndx[hh]; ndx[hh] := tmp; // Exchg32(ndx[ll],ndx[hh]);
until false;
// swap middle item (in position low) back into correct position
Exchg32(ndx[low],ndx[hh]);
// next active partition
if hh<=median then
low := ll;
if hh>=median then
high := hh-1;
until false;
end;
function gcd(a, b: cardinal): cardinal;
begin
while a <> b do
if a > b then
dec(a, b) else
dec(b, a);
result := a;
end;
function ToVarUInt32Length(Value: PtrUInt): PtrUInt;
begin
if Value<=$7f then
result := 1 else
if Value<$80 shl 7 then
result := 2 else
if Value<$80 shl 14 then
result := 3 else
if Value <$80 shl 21 then
result := 4 else
result := 5;
end;
function ToVarUInt32LengthWithData(Value: PtrUInt): PtrUInt;
begin
if Value<=$7f then
result := Value+1 else
if Value<$80 shl 7 then
result := Value+2 else
if Value<$80 shl 14 then
result := Value+3 else
if Value<$80 shl 21 then
result := Value+4 else
result := Value+5;
end;
{$ifdef HASINLINE}
function FromVarUInt32(var Source: PByte): cardinal;
begin
result := Source^;
inc(Source);
if result>$7f then
result := (result and $7F) or FromVarUInt32Up128(Source);
end;
function FromVarUInt32Big(var Source: PByte): cardinal;
{$else}
function FromVarUInt32Big(var Source: PByte): cardinal;
asm
jmp FromVarUInt32
end;
function FromVarUInt32(var Source: PByte): cardinal;
{$endif}
var c: cardinal;
p: PByte;
begin
p := Source;
result := p^;
inc(p);
if result>$7f then begin // Values between 128 and 16256
c := p^;
c := c shl 7;
result := result and $7F or c;
inc(p);
if c>$7f shl 7 then begin // Values between 16257 and 2080768
c := p^;
c := c shl 14;
inc(p);
result := result and $3FFF or c;
if c>$7f shl 14 then begin // Values between 2080769 and 266338304
c := p^;
c := c shl 21;
inc(p);
result := result and $1FFFFF or c;
if c>$7f shl 21 then begin
c := p^;
c := c shl 28;
inc(p);
result := result and $FFFFFFF or c;
end;
end;
end;
end;
Source := p;
end;
function FromVarUInt32Up128(var Source: PByte): cardinal;
var c: cardinal;
p: PByte;
begin // Values above 128
p := Source;
result := p^ shl 7;
inc(p);
if result>$7f shl 7 then begin // Values above 16257
c := p^;
c := c shl 14;
inc(p);
result := result and $3FFF or c;
if c>$7f shl 14 then begin
c := p^;
c := c shl 21;
inc(p);
result := result and $1FFFFF or c;
if c>$7f shl 21 then begin
c := p^;
c := c shl 28;
inc(p);
result := result and $FFFFFFF or c;
end;
end;
end;
Source := p;
end;
function FromVarUInt32(var Source: PByte; SourceMax: PByte; out Value: cardinal): boolean;
begin
if SourceMax=nil then begin
Value := FromVarUInt32(Source);
result := true;
end else begin
Source := FromVarUInt32Safe(Source,SourceMax,Value);
result := Source<>nil;
end;
end;
function FromVarUInt32Safe(Source, SourceMax: PByte; out Value: cardinal): PByte;
var c: cardinal;
begin
result := nil; // error
if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit;
c := Source^;
inc(Source);
Value := c;
if c>$7f then begin // Values between 128 and 16256
if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit;
c := Source^;
c := c shl 7;
Value := Value and $7F or c;
inc(Source);
if c>$7f shl 7 then begin // Values between 16257 and 2080768
if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit;
c := Source^;
c := c shl 14;
inc(Source);
Value := Value and $3FFF or c;
if c>$7f shl 14 then begin // Values between 2080769 and 266338304
if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit;
c := Source^;
c := c shl 21;
inc(Source);
Value := Value and $1FFFFF or c;
if c>$7f shl 21 then begin
if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit;
c := Source^;
c := c shl 28;
inc(Source);
Value := Value and $FFFFFFF or c;
end;
end;
end;
end;
result := Source; // safely decoded
end;
function FromVarInt32(var Source: PByte): integer;
var c: cardinal;
p: PByte;
begin // fast stand-alone function with no FromVarUInt32 call
p := Source;
result := p^;
inc(p);
if result>$7f then begin
c := p^;
c := c shl 7;
result := result and $7F or integer(c);
inc(p);
if c>$7f shl 7 then begin
c := p^;
c := c shl 14;
inc(p);
result := result and $3FFF or integer(c);
if c>$7f shl 14 then begin
c := p^;
c := c shl 21;
inc(p);
result := result and $1FFFFF or integer(c);
if c>$7f shl 21 then begin
c := p^;
c := c shl 28;
inc(p);
result := result and $FFFFFFF or integer(c);
end;
end;
end;
end;
Source := p;
// 0=0,1=1,2=-1,3=2,4=-2...
if result and 1<>0 then
// 1->1, 3->2..
result := result shr 1+1 else
// 0->0, 2->-1, 4->-2..
result := -(result shr 1);
end;
function FromVarUInt32High(var Source: PByte): cardinal;
var c: cardinal;
begin
result := Source^;
inc(Source);
c := Source^ shl 7;
inc(Source);
result := result and $7F or c;
if c<=$7f shl 7 then
exit;
c := Source^ shl 14;
inc(Source);
result := result and $3FFF or c;
if c<=$7f shl 14 then
exit;
c := Source^ shl 21;
inc(Source);
result := result and $1FFFFF or c;
if c<=$7f shl 21 then
exit;
c := Source^ shl 28;
inc(Source);
result := result and $FFFFFFF or c;
end;
function ToVarInt64(Value: Int64; Dest: PByte): PByte;
begin // 0=0,1=1,2=-1,3=2,4=-2...
{$ifdef CPU32}
if Value<=0 then
// 0->0, -1->2, -2->4..
result := ToVarUInt64((-Value) shl 1,Dest) else
// 1->1, 2->3..
result := ToVarUInt64((Value shl 1)-1,Dest);
{$else}
if Value<=0 then
// 0->0, -1->2, -2->4..
Value := (-Value) shl 1 else
// 1->1, 2->3..
Value := (Value shl 1)-1;
result := ToVarUInt64(Value,Dest);
{$endif}
end;
function ToVarUInt64(Value: QWord; Dest: PByte): PByte;
label _1,_2,_4; // ugly but fast
var c: cardinal;
begin
repeat
c := Value;
if {$ifdef CPU32}PInt64Rec(@Value)^.Hi=0{$else}Value shr 32=0{$endif} then begin
if c>$7f then begin // inlined result := ToVarUInt32(Value,Dest);
if c<$80 shl 7 then goto _1 else
if c<$80 shl 14 then goto _2 else
if c>=$80 shl 21 then goto _4;
Dest^ := (c and $7F) or $80;
c := c shr 7;
inc(Dest);
_2: Dest^ := (c and $7F) or $80;
c := c shr 7;
inc(Dest);
_1: Dest^ := (c and $7F) or $80;
c := c shr 7;
inc(Dest);
end;
Dest^ := c;
inc(Dest);
result := Dest;
exit;
end;
_4: PCardinal(Dest)^ := (c and $7F) or (((c shr 7)and $7F)shl 8) or
(((c shr 14)and $7F)shl 16) or (((c shr 21)and $7F)shl 24) or $80808080;
inc(Dest,4);
Value := Value shr 28;
until false;
end;
function FromVarUInt64(var Source: PByte): QWord;
var c,n: PtrUInt;
p: PByte;
begin
p := Source;
{$ifdef CPU64}
result := p^;
if result>$7f then begin
result := result and $7F;
{$else}
if p^>$7f then begin
result := PtrUInt(p^) and $7F;
{$endif}
n := 0;
inc(p);
repeat
c := p^;
inc(n,7);
if c<=$7f then
break;
result := result or (QWord(c and $7f) shl n);
inc(p);
until false;
result := result or (QWord(c) shl n);
end{$ifndef CPU64} else
result := p^{$endif};
inc(p);
Source := p;
end;
function FromVarUInt64Safe(Source, SourceMax: PByte; out Value: QWord): PByte;
var c,n: PtrUInt;
begin
result := nil; // error
if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit;
c := Source^;
inc(Source);
if c>$7f then begin
Value := c and $7F;
n := 7;
repeat
if PAnsiChar(Source)>=PAnsiChar(SourceMax) then
exit;
c := Source^;
inc(Source);
if c<=$7f then
break;
c := c and $7f;
Value := Value or (QWord(c) shl n);
inc(n,7);
until false;
Value := Value or (QWord(c) shl n);
end else
Value := c;
result := Source; // safely decoded
end;
function FromVarUInt64(var Source: PByte; SourceMax: PByte; out Value: QWord): boolean;
begin
if SourceMax=nil then begin
Value := FromVarUInt64(Source);
result := true;
end else begin
Source := FromVarUInt64Safe(Source,SourceMax,Value);
result := Source<>nil;
end;
end;
function FromVarInt64(var Source: PByte): Int64;
var c,n: PtrUInt;
begin // 0=0,1=1,2=-1,3=2,4=-2...
{$ifdef CPU64}
result := Source^;
if result>$7f then begin
result := result and $7F;
n := 0;
inc(Source);
repeat
c := Source^;
inc(n,7);
if c<=$7f then
break;
result := result or (Int64(c and $7f) shl n);
inc(Source);
until false;
result := result or (Int64(c) shl n);
end;
if result and 1<>0 then
// 1->1, 3->2..
result := result shr 1+1 else
// 0->0, 2->-1, 4->-2..
result := -(result shr 1);
{$else}
c := Source^;
if c>$7f then begin
result := c and $7F;
n := 0;
inc(Source);
repeat
c := Source^;
inc(n,7);
if c<=$7f then
break;
result := result or (Int64(c and $7f) shl n);
inc(Source);
until false;
result := result or (Int64(c) shl n);
if PCardinal(@result)^ and 1<>0 then
// 1->1, 3->2..
result := result shr 1+1 else
// 0->0, 2->-1, 4->-2..
result := -(result shr 1);
end else begin
if c=0 then
result := 0 else
if c and 1=0 then
// 0->0, 2->-1, 4->-2..
result := -Int64(c shr 1) else
// 1->1, 3->2..
result := (c shr 1)+1;
end;
{$endif}
inc(Source);
end;
function FromVarInt64Value(Source: PByte): Int64;
{$ifdef DELPHI5OROLDER}
begin // try to circumvent Internal Error C1093 on Delphi 5 :(
result := FromVarInt64(Source);
end;
{$else}
var c,n: PtrUInt;
begin // 0=0,1=1,2=-1,3=2,4=-2...
c := Source^;
if c>$7f then begin
result := c and $7F;
n := 0;
inc(Source);
repeat
c := Source^;
inc(n,7);
if c<=$7f then
break;
result := result or (Int64(c and $7f) shl n);
inc(Source);
until false;
result := result or (Int64(c) shl n);
if {$ifdef CPU64}result{$else}PCardinal(@result)^{$endif} and 1<>0 then
// 1->1, 3->2..
result := result shr 1+1 else
// 0->0, 2->-1, 4->-2..
result := -Int64(result shr 1);
end else
if c=0 then
result := 0 else
if c and 1=0 then
// 0->0, 2->-1, 4->-2..
result := -Int64(c shr 1) else
// 1->1, 3->2..
result := (c shr 1)+1;
end;
{$endif DELPHI5OROLDER}
function GotoNextVarInt(Source: PByte): pointer;
begin
if Source<>nil then begin
if Source^>$7f then
repeat
inc(Source)
until Source^<=$7f;
inc(Source);
end;
result := Source;
end;
function ToVarString(const Value: RawUTF8; Dest: PByte): PByte;
var Len: integer;
begin
Len := Length(Value);
Dest := ToVarUInt32(Len,Dest);
if Len>0 then begin
MoveFast(pointer(Value)^,Dest^,Len);
result := pointer(PAnsiChar(Dest)+Len);
end else
result := Dest;
end;
function GotoNextVarString(Source: PByte): pointer;
begin
result := Pointer(PtrUInt(Source)+FromVarUInt32(Source));
end;
function FromVarString(var Source: PByte): RawUTF8;
var len: PtrUInt;
begin
len := FromVarUInt32(Source);
FastSetStringCP(Result,Source,len,CP_UTF8);
inc(Source,len);
end;
function FromVarString(var Source: PByte; SourceMax: PByte): RawUTF8;
var len: cardinal;
begin
Source := FromVarUInt32Safe(Source,SourceMax,len);
if (Source=nil) or (PAnsiChar(Source)+len>PAnsiChar(SourceMax)) then
len := 0;
FastSetStringCP(Result,Source,len,CP_UTF8);
inc(Source,len);
end;
procedure FromVarString(var Source: PByte; var Value: TSynTempBuffer);
var len: integer;
begin
len := FromVarUInt32(Source);
Value.Init(Source,len);
PByteArray(Value.buf)[len] := 0; // include trailing #0
inc(Source,len);
end;
function FromVarString(var Source: PByte; SourceMax: PByte;
var Value: TSynTempBuffer): boolean;
var len: cardinal;
begin
if SourceMax=nil then
len := FromVarUInt32(Source) else begin
Source := FromVarUInt32Safe(Source,SourceMax,len);
if (Source=nil) or (PAnsiChar(Source)+len>PAnsiChar(SourceMax)) then begin
result := false;
exit;
end;
end;
Value.Init(Source,len);
PByteArray(Value.buf)[len] := 0; // include trailing #0
inc(Source,len);
result := true;
end;
procedure FromVarString(var Source: PByte; var Value: RawByteString;
CodePage: integer);
var Len: PtrUInt;
begin
Len := FromVarUInt32(Source);
FastSetStringCP(Value,Source,Len,CodePage);
inc(Source,Len);
end;
function FromVarString(var Source: PByte; SourceMax: PByte;
var Value: RawByteString; CodePage: integer): boolean;
var len: cardinal;
begin
if SourceMax=nil then
len := FromVarUInt32(Source) else begin
Source := FromVarUInt32Safe(Source,SourceMax,len);
if (Source=nil) or (PAnsiChar(Source)+len>PAnsiChar(SourceMax)) then begin
result := false;
exit;
end;
end;
FastSetStringCP(Value,Source,len,CodePage);
inc(Source,len);
result := true;
end;
function FromVarBlob(Data: PByte): TValueResult;
begin
Result.Len := FromVarUInt32(Data);
Result.Ptr := pointer(Data);
end;
{ ************ low-level RTTI types and conversion routines }
{$ifdef FPC}
{$ifdef FPC_OLDRTTI}
function OldRTTIFirstManagedField(info: PTypeInfo): PFieldInfo;
var fieldtype: PTypeInfo;
i: integer;
begin
result := @info^.ManagedFields[0];
for i := 1 to info^.ManagedCount do begin
fieldtype := DeRef(result^.TypeInfo);
if (fieldtype<>nil) and (fieldtype^.Kind in tkManagedTypes) then
exit;
inc(result);
end;
result := nil;
end;
function OldRTTIManagedSize(typeInfo: Pointer): SizeInt; inline;
begin
case PTypeKind(typeInfo)^ of // match tkManagedTypes
tkLString,tkLStringOld,tkWString,tkUString, tkInterface,tkDynarray:
result := SizeOf(Pointer);
{$ifndef NOVARIANTS}
tkVariant: result := SizeOf(TVarData);
{$endif}
tkArray: with GetTypeInfo(typeInfo)^ do
result := arraySize{$ifdef VER2_6}*elCount{$endif};
tkObject,tkRecord: result := GetTypeInfo(typeInfo)^.recSize;
else raise ESynException.CreateUTF8('OldRTTIManagedSize unhandled % (%)',
[ToText(PTypeKind(typeInfo)^)^,PByte(typeInfo)^]);
end;
end;
procedure RecordCopy(var Dest; const Source; TypeInfo: pointer);
begin // external name 'FPC_COPY' does not work as we need
FPCFinalize(@Dest,TypeInfo);
Move(Source,Dest,OldRTTIManagedSize(TypeInfo));
FPCRecordAddRef(Dest,TypeInfo);
end;
{$else}
procedure RecordCopy(var Dest; const Source; TypeInfo: pointer);
begin
FPCRecordCopy(Source,Dest,TypeInfo);
end;
{$endif FPC_OLDRTTI}
procedure RecordClear(var Dest; TypeInfo: pointer);
begin
FPCFinalize(@Dest,TypeInfo);
end;
{$else FPC}
procedure CopyArray(dest, source, typeInfo: Pointer; cnt: PtrUInt);
asm
{$ifdef CPU64}
.noframe
jmp System.@CopyArray
{$else} push dword ptr[EBP + 8]
call System.@CopyArray // RTL is fast enough for this
{$endif}
end;
procedure _DynArrayClear(var a: Pointer; typeInfo: Pointer);
asm
{$ifdef CPU64}
.noframe
{$endif}
jmp System.@DynArrayClear
end;
procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: PtrUInt);
asm
{$ifdef CPU64}
.noframe
{$endif}
jmp System.@FinalizeArray
end;
procedure _Finalize(Data: Pointer; TypeInfo: Pointer);
asm
{$ifdef CPU64}
.noframe
mov r8, 1 // rcx=p rdx=typeInfo r8=ElemCount
jmp System.@FinalizeArray
{$else} // much faster than FinalizeArray(Data,TypeInfo,1)
movzx ecx, byte ptr[edx] // eax=ptr edx=typeinfo ecx=datatype
sub cl, tkLString
{$ifdef UNICODE}
cmp cl, tkUString - tkLString + 1
{$else}
cmp cl, tkDynArray - tkLString + 1
{$endif}
jnb @@err
jmp dword ptr[@@Tab + ecx * 4]
nop
nop // for @@Tab alignment
@@Tab: dd System.@LStrClr
{$IFDEF LINUX} // under Linux, WideString are refcounted as AnsiString
dd System.@LStrClr
{$else} dd System.@WStrClr
{$endif LINUX}
{$ifdef LVCL}
dd @@err
{$else} dd System.@VarClr
{$endif LVCL}
dd @@ARRAY
dd RecordClear
dd System.@IntfClear
dd @@err
dd System.@DynArrayClear
{$ifdef UNICODE}
dd System.@UStrClr
{$endif}
@@err: mov al, reInvalidPtr
{$ifdef DELPHI5OROLDER}
jmp System.@RunError
{$else}
jmp System.Error
{$endif}
@@array:movzx ecx, [edx].TTypeInfo.NameLen
add ecx, edx
mov edx, dword ptr[ecx].TTypeInfo.ManagedFields[0] // Fields[0].TypeInfo^
mov ecx, [ecx].TTypeInfo.ManagedCount
mov edx, [edx]
jmp System.@FinalizeArray
{$endif CPU64}
end;
{$endif FPC}
procedure RecordZero(var Dest; TypeInfo: pointer);
var info: PTypeInfo;
begin
info := GetTypeInfo(TypeInfo,tkRecordKinds);
if info<>nil then begin // record/object only
RecordClear(Dest,TypeInfo);
FillCharFast(Dest,info^.recSize,0);
end;
end;
procedure RawUTF8DynArrayClear(var Value: TRawUTF8DynArray);
begin
FastDynArrayClear(@Value,TypeInfo(RawUTF8));
end;
function ArrayItemType(var info: PTypeInfo; out len: integer): PTypeInfo;
{$ifdef HASINLINE}inline;{$endif}
begin
{$ifdef HASALIGNTYPEDATA} // inlined info := GetTypeInfo(info)
info := FPCTypeInfoOverName(info);
{$else}
info := @PAnsiChar(info)[info^.NameLen];
{$endif}
result := nil;
if (info=nil) or (info^.dimCount<>1) then begin
len := 0;
info := nil; // supports single dimension static array only
end else begin
len := info^.arraySize{$ifdef VER2_6}*info^.elCount{$endif};
{$ifdef HASDIRECTTYPEINFO} // inlined result := DeRef(info^.arrayType)
result := info^.arrayType;
{$else}
if info^.arrayType=nil then
exit;
result := info^.arrayType^;
{$endif}
{$ifdef FPC}
if (result<>nil) and not(result^.Kind in tkManagedTypes) then
result := nil; // as with Delphi
{$endif}
end;
end;
function ManagedTypeCompare(A,B: PAnsiChar; info: PTypeInfo): integer;
// returns -1 if info was not handled, 0 if A^<>B^, or SizeOf(A^) if A^=B^
var i,arraysize: integer;
itemtype: PTypeInfo;
{$ifndef DELPHI5OROLDER} // do not know why this compiler does not like it
DynA, DynB: TDynArray;
{$endif}
begin // info is expected to come from a DeRef() if retrieved from RTTI
result := 0; // A^<>B^
case info^.Kind of // should match tkManagedTypes
tkLString{$ifdef FPC},tkLStringOld{$endif}:
if PRawByteString(A)^=PRawByteString(B)^ then
result := SizeOf(pointer);
tkWString:
if PWideString(A)^=PWideString(B)^ then
result := SizeOf(pointer);
{$ifdef HASVARUSTRING}
tkUString:
if PUnicodeString(A)^=PUnicodeString(B)^ then
result := SizeOf(pointer);
{$endif}
tkRecord{$ifdef FPC},tkObject{$endif}:
if not RecordEquals(A^,B^,info,@result) then
result := 0; // A^<>B^
{$ifndef NOVARIANTS}
tkVariant: // slightly more optimized than PVariant(A)^=PVariant(B)^
if SortDynArrayVariantComp(PVarData(A)^,PVarData(B)^,false)=0 then
result := SizeOf(variant);
{$endif}
{$ifndef DELPHI5OROLDER}
tkDynArray: begin
DynA.Init(info,A^);
DynB.Init(info,B^);
if DynA.Equals(DynB) then
result := SizeOf(pointer);
end;
{$endif}
tkInterface:
if PPointer(A)^=PPointer(B)^ then
result := SizeOf(pointer);
tkArray: begin
itemtype := ArrayItemType(info,arraysize);
if info=nil then
result := -1 else
if itemtype=nil then
if CompareMemFixed(A,B,arraysize) then
result := arraysize else
result := 0 else begin
for i := 1 to info^.elCount do begin // only compare managed fields
result := ManagedTypeCompare(A,B,itemtype);
if result<=0 then
exit; // invalid (-1) or not equals (0)
inc(A,result);
inc(B,result);
end;
result := arraysize;
end;
end;
else
result := -1; // Unhandled field
end;
end;
function ManagedTypeSaveLength(data: PAnsiChar; info: PTypeInfo;
out len: integer): integer;
// returns 0 on error, or saved bytes + len=data^ length
var DynArray: TDynArray;
itemtype: PTypeInfo;
itemsize,size,i: integer;
P: PPtrUInt absolute data;
begin // info is expected to come from a DeRef() if retrieved from RTTI
case info^.Kind of // should match tkManagedTypes
tkLString{$ifdef FPC},tkLStringOld{$endif}: begin
len := SizeOf(pointer);
if P^=0 then
result := 1 else
result := ToVarUInt32LengthWithData(PStrLen(P^-_STRLEN)^);
end;
tkWString: begin // PStrRec doesn't match on Widestring for FPC
len := SizeOf(pointer);
result := ToVarUInt32LengthWithData(length(PWideString(P)^)*2);
end;
{$ifdef HASVARUSTRING}
tkUString: begin
len := SizeOf(pointer);
if P^=0 then
result := 1 else
result := ToVarUInt32LengthWithData(PStrLen(P^-_STRLEN)^*2);
end;
{$endif}
tkRecord{$ifdef FPC},tkObject{$endif}:
result := RecordSaveLength(data^,info,@len);
tkArray: begin
itemtype := ArrayItemType(info,len);
result := 0;
if info<>nil then
if itemtype=nil then
result := len else
for i := 1 to info^.elCount do begin
size := ManagedTypeSaveLength(data,itemtype,itemsize);
if size=0 then begin
result := 0;
exit;
end;
inc(result,size);
inc(data,itemsize);
end;
end;
{$ifndef NOVARIANTS}
tkVariant: begin
len := SizeOf(variant);
result := VariantSaveLength(PVariant(data)^);
end;
{$endif}
tkDynArray: begin
DynArray.Init(info,data^);
len := SizeOf(pointer);
result := DynArray.SaveToLength;
end;
tkInterface: begin
len := SizeOf(Int64); // consume 64-bit even on CPU32
result := SizeOf(PtrUInt);
end;
else
result := 0; // invalid/unhandled record content
end;
end;
function ManagedTypeSave(data, dest: PAnsiChar; info: PTypeInfo;
out len: integer): PAnsiChar;
// returns nil on error, or final dest + len=data^ length
var DynArray: TDynArray;
itemtype: PTypeInfo;
itemsize,i: integer;
P: PPtrUInt absolute data;
begin // info is expected to come from a DeRef() if retrieved from RTTI
case info^.Kind of
tkLString {$ifdef HASVARUSTRING},tkUString{$endif} {$ifdef FPC},tkLStringOld{$endif}: begin
if P^=0 then begin
dest^ := #0;
result := dest+1;
end else begin
itemsize := PStrLen(P^-_STRLEN)^;
{$ifdef HASVARUSTRING} // UnicodeString length in WideChars
if info^.Kind=tkUString then
itemsize := itemsize*2;
{$endif}
result := pointer(ToVarUInt32(itemsize,pointer(dest)));
MoveFast(pointer(P^)^,result^,itemsize);
inc(result,itemsize);
end;
len := SizeOf(PtrUInt); // size of tkLString/tkUString in record
end;
tkWString: begin
itemsize := length(PWideString(P)^)*2; // PStrRec doesn't match on FPC
result := pointer(ToVarUInt32(itemsize,pointer(dest)));
MoveFast(pointer(P^)^,result^,itemsize);
inc(result,itemsize);
len := SizeOf(PtrUInt);
end;
tkRecord{$ifdef FPC},tkObject{$endif}:
result := RecordSave(data^,dest,info,len);
tkArray: begin
itemtype := ArrayItemType(info,len);
if info=nil then
result := nil else
if itemtype=nil then begin
MoveSmall(data,dest,len);
result := dest+len;
end else begin
for i := 1 to info^.elCount do begin
dest := ManagedTypeSave(data,dest,itemtype,itemsize);
if dest=nil then
break; // invalid/unhandled content
inc(data,itemsize)
end;
result := dest;
end;
end;
{$ifndef NOVARIANTS}
tkVariant: begin
result := VariantSave(PVariant(data)^,dest);
len := SizeOf(Variant); // size of tkVariant in record
end;
{$endif}
tkDynArray: begin
DynArray.Init(info,data^);
result := DynArray.SaveTo(dest);
len := SizeOf(PtrUInt); // size of tkDynArray in record
end;
{$ifndef DELPHI5OROLDER}
tkInterface: begin
PIInterface(dest)^ := PIInterface(data)^; // with proper refcount
result := dest+SizeOf(Int64); // consume 64-bit even on CPU32
len := SizeOf(PtrUInt);
end;
{$endif}
else
result := nil; // invalid/unhandled record content
end;
end;
function ManagedTypeLoad(data: PAnsiChar; var source: PAnsiChar;
info: PTypeInfo; sourceMax: PAnsiChar): integer;
// returns source=nil on error, or final source + result=data^ length
var DynArray: TDynArray;
itemtype: PTypeInfo;
itemsize: cardinal;
i: PtrInt;
begin // info is expected to come from a DeRef() if retrieved from RTTI
result := SizeOf(PtrUInt); // size of most items
if info^.Kind in [tkLString{$ifdef FPC},tkLStringOld{$endif},tkWString
{$ifdef HASVARUSTRING},tkUString{$endif}] then
if sourceMax<>nil then begin
source := pointer(FromVarUInt32Safe(PByte(source),PByte(sourceMax),itemsize));
if source=nil then
exit;
if source+itemsize>sourceMax then begin
source := nil;
exit; // avoid buffer overflow
end;
end else
itemsize := FromVarUInt32(PByte(source)); // in source buffer bytes
case info^.Kind of
tkLString{$ifdef FPC}, tkLStringOld{$endif}: begin
{$ifdef HASCODEPAGE}
FastSetStringCP(data^,source,itemsize,LStringCodePage(info));
{$else}
SetString(PRawUTF8(data)^,source,itemsize);
{$endif HASCODEPAGE}
inc(source,itemsize);
end;
tkWString: begin
SetString(PWideString(data)^,PWideChar(source),itemsize shr 1);
inc(source,itemsize);
end;
{$ifdef HASVARUSTRING}
tkUString: begin
SetString(PUnicodeString(data)^,PWideChar(source),itemsize shr 1);
inc(source,itemsize);
end;
{$endif}
tkRecord{$ifdef FPC},tkObject{$endif}:
source := RecordLoad(data^,source,info,@result,sourceMax);
tkArray: begin
itemtype := ArrayItemType(info,result);
if info=nil then
source := nil else
if itemtype=nil then
if (sourceMax<>nil) and (source+result>sourceMax) then
source := nil else begin
MoveSmall(source,data,result);
inc(source,result);
end else
for i := 1 to info^.elCount do begin
inc(data,ManagedTypeLoad(data,source,itemtype,sourceMax));
if source=nil then
exit;
end;
end;
{$ifndef NOVARIANTS}
tkVariant: begin
source := VariantLoad(PVariant(data)^,source,@JSON_OPTIONS[true]);
result := SizeOf(Variant); // size of tkVariant in record
end;
{$endif NOVARIANTS}
tkDynArray: begin
DynArray.Init(info,data^);
source := DynArray.LoadFrom(source,nil,{nohash=}true,sourceMax);
end;
{$ifndef DELPHI5OROLDER}
tkInterface: begin
if (sourceMax<>nil) and (source+SizeOf(Int64)>sourceMax) then begin
source := nil;
exit;
end;
PIInterface(data)^ := PIInterface(source)^; // with proper refcount
inc(source,SizeOf(Int64)); // consume 64-bit even on CPU32
end;
{$endif DELPHI5OROLDER}
else
source := nil; // notify error for unexpected input type
end;
end;
function GetManagedFields(info: PTypeInfo; out firstfield: PFieldInfo): integer;
{$ifdef HASINLINE}inline;{$endif}
{$ifdef FPC_NEWRTTI}
var
recInitData: PFPCRecInitData; // low-level type redirected from SynFPCTypInfo
aPointer:pointer;
begin
if Assigned(info^.RecInitInfo) then
recInitData := PFPCRecInitData(AlignTypeDataClean(PTypeInfo(info^.RecInitInfo+2+PByte(info^.RecInitInfo+1)^)))
else begin
aPointer:=@info^.RecInitInfo;
{$ifdef FPC_PROVIDE_ATTR_TABLE}
dec(PByte(aPointer),SizeOf(Pointer));
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
{$ifdef CPUARM}
dec(PByte(aPointer),SizeOf(Pointer));
{$endif CPUARM}
{$endif}
{$endif}
recInitData := PFPCRecInitData(aPointer);
end;
firstfield := PFieldInfo(PtrUInt(@recInitData^.ManagedFieldCount));
inc(PByte(firstfield),SizeOf(recInitData^.ManagedFieldCount));
firstfield := AlignPTypeInfo(firstfield);
result := recInitData^.ManagedFieldCount;
{$else}
begin
firstfield := @info^.ManagedFields[0];
result := info^.ManagedCount;
{$endif FPC_NEWRTTI}
end;
function RecordEquals(const RecA, RecB; TypeInfo: pointer;
PRecSize: PInteger): boolean;
var info,fieldinfo: PTypeInfo;
F, offset: PtrInt;
field: PFieldInfo;
A, B: PAnsiChar;
begin
A := @RecA;
B := @RecB;
result := false;
info := GetTypeInfo(TypeInfo,tkRecordKinds);
if info=nil then
exit; // raise Exception.CreateUTF8('% is not a record',[Typ^.Name]);
if PRecSize<>nil then
PRecSize^ := info^.recSize;
if A=B then begin // both nil or same pointer
result := true;
exit;
end;
offset := 0;
for F := 1 to GetManagedFields(info,field) do begin
fieldinfo := DeRef(field^.TypeInfo);
{$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields
if not (fieldinfo^.Kind in tkManagedTypes) then begin
inc(field);
continue; // as with Delphi
end;
{$endif}
offset := integer(field^.Offset)-offset;
if offset<>0 then begin
if not CompareMemFixed(A,B,offset) then
exit; // binary block not equal
inc(A,offset);
inc(B,offset);
end;
offset := ManagedTypeCompare(A,B,fieldinfo);
if offset<=0 then
if offset=0 then // A^<>B^
exit else // Diff=-1 for unexpected type
raise ESynException.CreateUTF8('RecordEquals: unexpected %',
[ToText(fieldinfo^.Kind)^]);
inc(A,offset);
inc(B,offset);
inc(offset,field^.Offset);
inc(field);
end;
if CompareMemFixed(A,B,integer(info^.recSize)-offset) then
result := true;
end;
function RecordSaveLength(const Rec; TypeInfo: pointer; Len: PInteger): integer;
var info,fieldinfo: PTypeInfo;
F, recsize,saved: integer;
field: PFieldInfo;
R: PAnsiChar;
begin
R := @Rec;
info := GetTypeInfo(TypeInfo,tkRecordKinds);
if (R=nil) or (info=nil) then begin
result := 0; // should have been checked before
exit;
end;
result := info^.recSize;
if Len<>nil then
Len^ := result;
for F := 1 to GetManagedFields(info,field) do begin
fieldinfo := DeRef(field^.TypeInfo);
{$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields! :)
if not (fieldinfo^.Kind in tkManagedTypes) then begin
inc(field);
continue; // as with Delphi
end;
{$endif};
saved := ManagedTypeSaveLength(R+field^.Offset,fieldinfo,recsize);
if saved=0 then begin
result := 0; // invalid type
exit;
end;
inc(result,saved-recsize); // extract recsize from info^.recSize
inc(field);
end;
end;
function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: pointer;
out Len: integer): PAnsiChar;
var info,fieldinfo: PTypeInfo;
F, offset: integer;
field: PFieldInfo;
R: PAnsiChar;
begin
R := @Rec;
info := GetTypeInfo(TypeInfo,tkRecordKinds);
if (R=nil) or (info=nil) then begin
result := nil; // should have been checked before
exit;
end;
Len := info^.recSize;
offset := 0;
for F := 1 to GetManagedFields(info,field) do begin
{$ifdef HASDIRECTTYPEINFO} // inlined DeRef()
fieldinfo := field^.TypeInfo;
{$else}
{$ifdef CPUINTEL}
fieldinfo := PPointer(field^.TypeInfo)^;
{$else}
fieldinfo := DeRef(field^.TypeInfo);
{$endif}
{$endif}
{$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields! :)
if not (fieldinfo^.Kind in tkManagedTypes) then begin
inc(field);
continue; // as with Delphi
end;
{$endif};
offset := integer(field^.Offset)-offset;
if offset>0 then begin
MoveFast(R^,Dest^,offset);
inc(R,offset);
inc(Dest,offset);
end;
Dest := ManagedTypeSave(R,Dest,fieldinfo,offset);
if Dest=nil then begin
result := nil; // invalid/unhandled record content
exit;
end;
inc(R,offset);
inc(offset,field.Offset);
inc(field);
end;
offset := integer(info^.recSize)-offset;
if offset<0 then
raise ESynException.Create('RecordSave offset<0') else
if offset<>0 then begin
MoveFast(R^,Dest^,offset);
result := Dest+offset;
end else
result := Dest;
end;
function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: pointer): PAnsiChar;
var dummylen: integer;
begin
result := RecordSave(Rec,Dest,TypeInfo,dummylen);
end;
function RecordSave(const Rec; TypeInfo: pointer): RawByteString;
var destlen,dummylen: integer;
dest: PAnsiChar;
begin
destlen := RecordSaveLength(Rec,TypeInfo);
SetString(result,nil,destlen);
if destlen<>0 then begin
dest := RecordSave(Rec,pointer(result),TypeInfo,dummylen);
if (dest=nil) or (dest-pointer(result)<>destlen) then // paranoid check
raise ESynException.CreateUTF8('RecordSave % len=%<>%',
[TypeInfoToShortString(TypeInfo)^,dest-pointer(result),destlen]);
end;
end;
function RecordSaveBytes(const Rec; TypeInfo: pointer): TBytes;
var destlen,dummylen: integer;
dest: PAnsiChar;
begin
destlen := RecordSaveLength(Rec,TypeInfo);
result := nil; // don't reallocate TBytes data from a previous call
SetLength(result,destlen);
if destlen<>0 then begin
dest := RecordSave(Rec,pointer(result),TypeInfo,dummylen);
if (dest=nil) or (dest-pointer(result)<>destlen) then // paranoid check
raise ESynException.CreateUTF8('RecordSave % len=%<>%',
[TypeInfoToShortString(TypeInfo)^,dest-pointer(result),destlen]);
end;
end;
procedure RecordSave(const Rec; var Dest: TSynTempBuffer; TypeInfo: pointer);
var dummylen: integer;
P: PAnsiChar;
begin
Dest.Init(RecordSaveLength(Rec,TypeInfo));
P := RecordSave(Rec,Dest.buf,TypeInfo,dummylen);
if (P=nil) or (P-Dest.buf<>Dest.len) then begin // paranoid check
Dest.Done;
raise ESynException.CreateUTF8('RecordSave TSynTempBuffer %',[TypeInfoToShortString(TypeInfo)^]);
end;
end;
function RecordSaveBase64(const Rec; TypeInfo: pointer; UriCompatible: boolean): RawUTF8;
var len,dummy: integer;
temp: TSynTempBuffer;
begin
result := '';
len := RecordSaveLength(Rec,TypeInfo);
if len=0 then
exit;
temp.Init(len+4);
RecordSave(Rec,PAnsiChar(temp.buf)+4,TypeInfo,dummy);
PCardinal(temp.buf)^ := crc32c(0,PAnsiChar(temp.buf)+4,len);
if UriCompatible then
result := BinToBase64uri(temp.buf,temp.len) else
result := BinToBase64(temp.buf,temp.len);
temp.Done;
end;
function RecordLoadBase64(Source: PAnsiChar; Len: PtrInt; var Rec;
TypeInfo: pointer; UriCompatible: boolean): boolean;
var temp: TSynTempBuffer;
begin
result := false;
if Len<=6 then
exit;
if UriCompatible then
result := Base64uriToBin(Source,Len,temp) else
result := Base64ToBin(Source,Len,temp);
result := result and (temp.len>=4) and
(crc32c(0,PAnsiChar(temp.buf)+4,temp.len-4)=PCardinal(temp.buf)^) and
(RecordLoad(Rec,PAnsiChar(temp.buf)+4,TypeInfo,nil,PAnsiChar(temp.buf)+temp.len)<>nil);
temp.Done;
end;
function RecordLoad(var Rec; Source: PAnsiChar; TypeInfo: pointer;
Len: PInteger; SourceMax: PAnsiChar): PAnsiChar;
var info,fieldinfo: PTypeInfo;
n, F: integer;
offset: PtrInt;
field: PFieldInfo;
R: PAnsiChar;
begin
result := nil; // indicates error
R := @Rec;
info := GetTypeInfo(TypeInfo,tkRecordKinds);
if (R=nil) or (info=nil) then // should have been checked before
exit;
if Len<>nil then
Len^ := info^.recSize;
n := GetManagedFields(info,field);
if Source=nil then begin // inline RecordClear() function
for F := 1 to n do begin
{$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(R+field^.Offset,Deref(field^.TypeInfo));
inc(field);
end;
exit;
end;
offset := 0;
for F := 1 to n do begin
{$ifdef HASDIRECTTYPEINFO} // inlined DeRef()
fieldinfo := field^.TypeInfo;
{$else}
{$ifdef CPUINTEL}
fieldinfo := PPointer(field^.TypeInfo)^;
{$else}
fieldinfo := DeRef(field^.TypeInfo);
{$endif}
{$endif}
{$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields! :)
if not (fieldinfo^.Kind in tkManagedTypes) then begin
inc(field);
continue; // as with Delphi
end;
{$endif};
offset := integer(field^.Offset)-offset;
if offset<>0 then begin
if (SourceMax<>nil) and (Source+offset>SourceMax) then
exit;
MoveFast(Source^,R^,offset);
inc(Source,offset);
inc(R,offset);
end;
offset := ManagedTypeLoad(R,Source,fieldinfo,SourceMax);
if Source=nil then
exit; // error at loading
inc(R,offset);
inc(offset,field^.Offset);
inc(field);
end;
offset := integer(info^.recSize)-offset;
if offset<0 then
raise ESynException.Create('RecordLoad offset<0') else
if offset<>0 then begin
if (SourceMax<>nil) and (Source+offset>SourceMax) then
exit;
MoveFast(Source^,R^,offset);
result := Source+offset;
end else
result := Source;
end;
function RecordLoad(var Res; const Source: RawByteString; TypeInfo: pointer): boolean;
var P: PAnsiChar;
begin
P := pointer(Source);
P := RecordLoad(Res,P,TypeInfo,nil,P+length(Source));
result := (P<>nil) and (P-pointer(Source)=length(Source));
end;
{$ifndef FPC}
{$ifdef USEPACKAGES}
{$define EXPECTSDELPHIRTLRECORDCOPYCLEAR}
{$endif}
{$ifdef DELPHI5OROLDER}
{$define EXPECTSDELPHIRTLRECORDCOPYCLEAR}
{$endif}
{$ifdef PUREPASCAL}
{$define EXPECTSDELPHIRTLRECORDCOPYCLEAR}
{$endif}
{$ifndef DOPATCHTRTL}
{$define EXPECTSDELPHIRTLRECORDCOPYCLEAR}
{$endif}
{$ifdef EXPECTSDELPHIRTLRECORDCOPYCLEAR}
procedure RecordCopy(var Dest; const Source; TypeInfo: pointer);
asm // same params than _CopyRecord{ dest, source, typeInfo: Pointer }
{$ifdef CPU64}
.noframe
{$endif}
jmp System.@CopyRecord
end;
procedure RecordClear(var Dest; TypeInfo: pointer);
asm
{$ifdef CPU64}
.noframe
{$endif}
jmp System.@FinalizeRecord
end;
{$endif EXPECTSDELPHIRTLRECORDCOPYCLEAR}
{$ifdef DOPATCHTRTL}
function SystemRecordCopyAddress: Pointer;
asm
{$ifdef CPU64}
mov rax,offset System.@CopyRecord
{$else}
mov eax,offset System.@CopyRecord
{$endif}
end;
function SystemFinalizeRecordAddress: Pointer;
asm
{$ifdef CPU64}
mov rax,offset System.@FinalizeRecord
{$else}
mov eax,offset System.@FinalizeRecord
{$endif}
end;
function SystemInitializeRecordAddress: Pointer;
asm
{$ifdef CPU64}
mov rax,offset System.@InitializeRecord
{$else}
mov eax,offset System.@InitializeRecord
{$endif}
end;
{$ifdef CPUX86}
procedure _InitializeRecord(P: Pointer; TypeInfo: Pointer);
asm // faster version by AB
{ -> EAX pointer to record to be finalized }
{ EDX pointer to type info }
(* // this TObject.Create-like initialization sounds slower
movzx ecx,byte ptr [edx].TTypeInfo.NameLen
mov edx,[edx+ecx].TTypeInfo.Size
xor ecx,ecx
jmp dword ptr [FillCharFast] *)
movzx ecx, byte ptr[edx].TTypeInfo.NameLen
push ebx
mov ebx, eax
push esi
push edi
mov edi, [edx + ecx].TTypeInfo.ManagedCount
lea esi, [edx + ecx].TTypeInfo.ManagedFields
test edi, edi
jz @end
@loop: mov edx, [esi].TFieldInfo.TypeInfo
mov eax, [esi].TFieldInfo.&Offset
mov edx, [edx]
add esi, 8
movzx ecx, [edx].TTypeInfo.Kind
add eax, ebx // eax=data to be initialized
jmp dword ptr[@tab + ecx * 4 - tkLString * 4]
@tab: dd @ptr, @ptr, @varrec, @array, @array, @ptr, @ptr, @ptr, @ptr
@ptr: mov dword ptr[eax], 0 // pointer initialization
dec edi
jg @loop
@end: pop edi
pop esi
pop ebx
ret
@varrec:xor ecx, ecx
mov dword ptr[eax], ecx
mov dword ptr[eax + 4], ecx
mov dword ptr[eax + 8], ecx
mov dword ptr[eax + 12], ecx
dec edi
jg @loop
pop edi
pop esi
pop ebx
ret
@array: mov ecx, 1 // here eax=data edx=typeinfo
call System.@InitializeArray
dec edi
jg @loop
pop edi
pop esi
pop ebx
end;
{$ifndef UNICODE} // TMonitor.Destroy is not available ! -> apply to D2007 only
procedure TObjectCleanupInstance;
asm // faster version by AB
push ebx
mov ebx, eax
@loop: mov ebx, [ebx] // handle three VMT levels per iteration
mov edx, [ebx].vmtInitTable
mov ebx, [ebx].vmtParent
test edx, edx
jnz @clr
test ebx, ebx
jz @end
mov ebx, [ebx]
mov edx, [ebx].vmtInitTable
mov ebx, [ebx].vmtParent
test edx, edx
jnz @clr
test ebx, ebx
jz @end
mov ebx, [ebx]
mov edx, [ebx].vmtInitTable
mov ebx, [ebx].vmtParent
test edx, edx
jnz @clr
test ebx, ebx
jnz @loop
@end: pop ebx
ret
@clr: push offset @loop // TObject has no vmtInitTable -> safe
jmp RecordClear // eax=self edx=typeinfo
end;
{$endif}
procedure RecordClear(var Dest; TypeInfo: pointer);
asm // faster version by AB (direct call to finalization procedures)
{ -> EAX pointer to record to be finalized }
{ EDX pointer to type info }
{ <- EAX pointer to record to be finalized }
movzx ecx, byte ptr[edx].TTypeInfo.NameLen
push ebx
mov ebx, eax
push esi
push edi
mov edi, [edx + ecx].TTypeInfo.ManagedCount
lea esi, [edx + ecx].TTypeInfo.ManagedFields
test edi, edi
jz @end
@loop: mov edx, [esi].TFieldInfo.TypeInfo
mov eax, [esi].TFieldInfo.&Offset
mov edx, [edx]
add esi, 8
movzx ecx, [edx].TTypeInfo.Kind
add eax, ebx // eax=data to be initialized
sub cl, tkLString
{$ifdef UNICODE}
cmp cl, tkUString - tkLString + 1
{$else} cmp cl, tkDynArray - tkLString + 1
{$endif}
jnb @err
call dword ptr[@Tab + ecx * 4]
dec edi
jg @loop
@end: mov eax, ebx // keep eax at return (see e.g. TObject.CleanupInstance)
pop edi
pop esi
pop ebx
ret
nop
nop
nop // align @Tab
@Tab: dd System.@LStrClr
{$IFDEF LINUX} // under Linux, WideString are refcounted as AnsiString
dd System.@LStrClr
{$else} dd System.@WStrClr
{$endif}
{$ifdef LVCL}
dd @err
{$else} dd System.@VarClr
{$endif}
dd @array
dd RecordClear
dd System.@IntfClear
dd @err
dd System.@DynArrayClear
{$ifdef UNICODE}
dd System.@UStrClr
{$endif}
@err: mov al, reInvalidPtr
pop edi
pop esi
pop ebx
jmp System.Error
@array: movzx ecx, [edx].TTypeInfo.NameLen
add ecx, edx
mov edx, dword ptr[ecx].TTypeInfo.ManagedFields[0] // Fields[0].TypeInfo^
mov ecx, [ecx].TTypeInfo.ManagedCount
mov edx, [edx]
call System.@FinalizeArray
// we made Call @Array -> ret to continue
end;
procedure RecordCopy(var Dest; const Source; TypeInfo: pointer);
asm // faster version of _CopyRecord{dest, source, typeInfo: Pointer} by AB
{ -> EAX pointer to dest }
{ EDX pointer to source }
{ ECX pointer to typeInfo }
push ebp
push ebx
push esi
push edi
movzx ebx, byte ptr[ecx].TTypeInfo.NameLen
mov esi, edx // esi = source
mov edi, eax // edi = dest
add ebx, ecx // ebx = TFieldTable
xor eax, eax // eax = current offset
mov ebp, [ebx].TTypeInfo.ManagedCount // ebp = TFieldInfo count
mov ecx, [ebx].TTypeInfo.recSize
test ebp, ebp
jz @fullcopy
push ecx // SizeOf(record) on stack
add ebx, offset TTypeInfo.ManagedFields[0] // ebx = first TFieldInfo
@next: mov ecx, [ebx].TFieldInfo.&Offset
mov edx, [ebx].TFieldInfo.TypeInfo
sub ecx, eax
mov edx, [edx]
jle @nomov
add esi, ecx
add edi, ecx
neg ecx
@mov1: mov al, [esi + ecx] // fast copy not destructable data
mov [edi + ecx], al
inc ecx
jnz @mov1
@nomov: mov eax, edi
movzx ecx, [edx].TTypeInfo.Kind
cmp ecx, tkLString
je @LString
jb @err
{$ifdef UNICODE}
cmp ecx, tkUString
je @UString
{$else} cmp ecx, tkDynArray
je @dynaray
{$endif} ja @err
jmp dword ptr[ecx * 4 + @tab - tkWString * 4]
@Tab: dd @WString, @variant, @array, @record, @interface, @err
{$ifdef UNICODE}
dd @dynaray
{$endif}
@errv: mov al, reVarInvalidOp
jmp @err2
@err: mov al, reInvalidPtr
@err2: pop edi
pop esi
pop ebx
pop ebp
jmp System.Error
nop // all functions below have esi=source edi=dest
@array: movzx ecx, byte ptr[edx].TTypeInfo.NameLen
push dword ptr[edx + ecx].TTypeInfo.recSize
push dword ptr[edx + ecx].TTypeInfo.ManagedCount
mov ecx, dword ptr[edx + ecx].TTypeInfo.ManagedFields[0] // Fields[0].TypeInfo^
mov ecx, [ecx]
mov edx, esi
call System.@CopyArray
pop eax // restore SizeOf(Array)
jmp @finish
@record:movzx ecx, byte ptr[edx].TTypeInfo.NameLen
mov ecx, [edx + ecx].TTypeInfo.recSize
push ecx
mov ecx, edx
mov edx, esi
call RecordCopy
pop eax // restore SizeOf(Record)
jmp @finish
nop
nop
nop
@variant:
{$ifdef NOVARCOPYPROC}
mov edx, esi
call System.@VarCopy
{$else} mov edx, esi
cmp dword ptr[VarCopyProc], 0
jz @errv
call [VarCopyProc]
{$endif}
mov eax, 16
jmp @finish
{$ifdef DELPHI6OROLDER}
nop
nop
{$endif}
@interface:
mov edx, [esi]
call System.@IntfCopy
jmp @fin4
nop
nop
nop
@dynaray:
mov ecx, edx // ecx=TypeInfo
mov edx, [esi]
call System.@DynArrayAsg
jmp @fin4
@WString:
{$ifndef LINUX}
mov edx, [esi]
call System.@WStrAsg
jmp @fin4
{$endif}
@LString:
mov edx, [esi]
call System.@LStrAsg
{$ifdef UNICODE}
jmp @fin4
nop
nop
@UString:
mov edx, [esi]
call System.@UStrAsg
{$endif}
@fin4: mov eax, 4
@finish:
add esi, eax
add edi, eax
add eax, [ebx].TFieldInfo.&Offset
add ebx, 8
dec ebp // any other TFieldInfo?
jnz @next
pop ecx // ecx= SizeOf(record)
@fullcopy:
mov edx, edi
sub ecx, eax
mov eax, esi
jle @nomov2
call dword ptr[MoveFast]
@nomov2: pop edi
pop esi
pop ebx
pop ebp
end;
{$endif CPUX86}
{$endif DOPATCHTRTL}
{$ifndef CPUARM}
function SystemFillCharAddress: Pointer;
asm
{$ifdef CPU64}
mov rax,offset System.@FillChar
{$else}
mov eax,offset System.@FillChar
{$endif}
end;
{$ifndef CPU64}
{$ifndef PUREPASCAL}
procedure FillCharX87;
asm // eax=Dest edx=Count cl=Value
// faster version by John O'Harrow (Code Size = 153 Bytes)
mov ch, cl // copy value into both bytes of cx
cmp edx, 32
jl @small
mov [eax], cx // fill first 8 bytes
mov [eax + 2], cx
mov [eax + 4], cx
mov [eax + 6], cx
sub edx, 16
fld qword ptr[eax]
fst qword ptr[eax + edx] // fill last 16 bytes
fst qword ptr[eax + edx + 8]
mov ecx, eax
and ecx, 7 // 8-byte align writes
sub ecx, 8
sub eax, ecx
add edx, ecx
add eax, edx
neg edx
@loop: fst qword ptr[eax + edx] // fill 16 bytes per loop
fst qword ptr[eax + edx + 8]
add edx, 16
jl @loop
ffree st(0)
fincstp
ret
nop
@small: test edx, edx
jle @done
mov [eax + edx - 1], cl // fill last byte
and edx, -2 // no. of words to fill
neg edx
lea edx, [@fill + 60 + edx * 2]
jmp edx
nop // align jump destinations
nop
@fill: mov [eax + 28], cx
mov [eax + 26], cx
mov [eax + 24], cx
mov [eax + 22], cx
mov [eax + 20], cx
mov [eax + 18], cx
mov [eax + 16], cx
mov [eax + 14], cx
mov [eax + 12], cx
mov [eax + 10], cx
mov [eax + 8], cx
mov [eax + 6], cx
mov [eax + 4], cx
mov [eax + 2], cx
mov [eax], cx
ret // for 4-bytes @fill alignment
@done: db $f3 // rep ret AMD trick here
end;
/// faster implementation of Move() for Delphi versions with no FastCode inside
procedure MoveX87;
asm // eax=source edx=dest ecx=count
// original code by John O'Harrow - included since delphi 2007
cmp eax, edx
jz @exit // exit if source=dest
cmp ecx, 32
ja @lrg // count > 32 or count < 0
sub ecx, 8
jg @sml // 9..32 byte move
jmp dword ptr[@table + 32 + ecx * 4] // 0..8 byte move
@sml: fild qword ptr[eax + ecx] // load last 8
fild qword ptr[eax] // load first 8
cmp ecx, 8
jle @sml16
fild qword ptr[eax + 8] // load second 8
cmp ecx, 16
jle @sml24
fild qword ptr[eax + 16] // load third 8
fistp qword ptr[edx + 16] // save third 8
@sml24: fistp qword ptr[edx + 8] // save second 8
@sml16: fistp qword ptr[edx] // save first 8
fistp qword ptr[edx + ecx] // save last 8
ret
@exit: rep ret
@table: dd @exit, @m01, @m02, @m03, @m04, @m05, @m06, @m07, @m08
@lrgfwd:push edx
fild qword ptr[eax] // first 8
lea eax, [eax + ecx - 8]
lea ecx, [ecx + edx - 8]
fild qword ptr[eax] // last 8
push ecx
neg ecx
and edx, -8 // 8-byte align writes
lea ecx, [ecx + edx + 8]
pop edx
@fwd: fild qword ptr[eax + ecx]
fistp qword ptr[edx + ecx]
add ecx, 8
jl @fwd
fistp qword ptr[edx] // last 8
pop edx
fistp qword ptr[edx] // first 8
ret
@lrg: jng @exit // count < 0
cmp eax, edx
ja @lrgfwd
sub edx, ecx
cmp eax, edx
lea edx, [edx + ecx]
jna @lrgfwd
sub ecx, 8 // backward move
push ecx
fild qword ptr[eax + ecx] // last 8
fild qword ptr[eax] // first 8
add ecx, edx
and ecx, -8 // 8-byte align writes
sub ecx, edx
@bwd: fild qword ptr[eax + ecx]
fistp qword ptr[edx + ecx]
sub ecx, 8
jg @bwd
pop ecx
fistp qword ptr[edx] // first 8
fistp qword ptr[edx + ecx] // last 8
ret
@m01: movzx ecx, byte ptr[eax]
mov [edx], cl
ret
@m02: movzx ecx, word ptr[eax]
mov [edx], cx
ret
@m03: mov cx, [eax]
mov al, [eax + 2]
mov [edx], cx
mov [edx + 2], al
ret
@m04: mov ecx, [eax]
mov [edx], ecx
ret
@m05: mov ecx, [eax]
mov al, [eax + 4]
mov [edx], ecx
mov [edx + 4], al
ret
@m06: mov ecx, [eax]
mov ax, [eax + 4]
mov [edx], ecx
mov [edx + 4], ax
ret
@m07: mov ecx, [eax]
mov eax, [eax + 3]
mov [edx], ecx
mov [edx + 3], eax
ret
@m08: mov ecx, [eax]
mov eax, [eax + 4]
mov [edx], ecx
mov [edx + 4], eax
end;
{$ifdef WITH_ERMS}
procedure FillCharERMSB; // Ivy Bridge+ Enhanced REP MOVSB/STOSB CPUs
asm // eax=Dest edx=Count cl=Value
test edx, edx
jle @none
cld
push edi
mov edi, eax
mov al, cl
mov ecx, edx
rep stosb
pop edi
@none:
end;
procedure MoveERMSB; // Ivy Bridge+ Enhanced REP MOVSB/STOSB CPUs
asm // eax=source edx=dest ecx=count
test ecx, ecx
jle @none
push esi
push edi
cmp edx, eax
ja @down
mov esi, eax
mov edi, edx
cld
rep movsb
pop edi
pop esi
@none:ret
@down:lea esi, [eax + ecx - 1]
lea edi, [edx + ecx - 1]
std
rep movsb
pop edi
pop esi
cld
end;
{$endif WITH_ERMS}
function StrLenX86(S: pointer): PtrInt;
// pure x86 function (if SSE2 not available) - faster than SysUtils' version
asm
test eax, eax
jz @0
cmp byte ptr[eax + 0], 0
je @0
cmp byte ptr[eax + 1], 0
je @1
cmp byte ptr[eax + 2], 0
je @2
cmp byte ptr[eax + 3], 0
je @3
push eax
and eax, -4 { DWORD Align Reads }
@Loop: add eax, 4
mov edx, [eax] { 4 Chars per Loop }
lea ecx, [edx - $01010101]
not edx
and edx, ecx
and edx, $80808080 { Set Byte to $80 at each #0 Position }
jz @Loop { Loop until any #0 Found }
pop ecx
bsf edx, edx { Find First #0 Position }
shr edx, 3 { Byte Offset of First #0 }
add eax, edx { Address of First #0 }
sub eax, ecx { Returns Length }
ret
@0: xor eax, eax
ret
@1: mov eax, 1
ret
@2: mov eax, 2
ret
@3: mov eax, 3
end;
{$ifndef DELPHI5OROLDER} // need SSE2 asm instruction set
procedure FillCharSSE2;
asm // Dest=eax Count=edx Value=cl
mov ch, cl {copy value into both bytes of cx}
cmp edx, 32
jl @small
sub edx, 16
movd xmm0, ecx
pshuflw xmm0, xmm0, 0
pshufd xmm0, xmm0, 0
movups [eax], xmm0 {fill first 16 bytes}
movups [eax + edx], xmm0 {fill last 16 bytes}
mov ecx, eax {16-byte align writes}
and ecx, 15
sub ecx, 16
sub eax, ecx
add edx, ecx
add eax, edx
neg edx
cmp edx, - 512 * 1024
jb @large
@loop: movaps [eax + edx], xmm0 {fill 16 bytes per loop}
add edx, 16
jl @loop
ret
@large: movntdq [eax + edx], xmm0 {fill 16 bytes per loop}
add edx, 16
jl @large
ret
@small: test edx, edx
jle @done
mov [eax + edx - 1], cl {fill last byte}
and edx, -2 {no. of words to fill}
neg edx
lea edx, [@smallfill + 60 + edx * 2]
jmp edx
nop {align jump destinations}
nop
@smallfill:
mov [eax + 28], cx
mov [eax + 26], cx
mov [eax + 24], cx
mov [eax + 22], cx
mov [eax + 20], cx
mov [eax + 18], cx
mov [eax + 16], cx
mov [eax + 14], cx
mov [eax + 12], cx
mov [eax + 10], cx
mov [eax + 8], cx
mov [eax + 6], cx
mov [eax + 4], cx
mov [eax + 2], cx
mov [eax], cx
ret {do not remove - this is for alignment}
@done:
end;
{$endif DELPHI5OROLDER}
{$endif PUREPASCAL}
{$endif CPU64}
{$endif CPUARM}
{$endif FPC}
{ ************ Custom record / dynamic array JSON serialization }
procedure SaveJSON(const Value; TypeInfo: pointer;
Options: TTextWriterOptions; var result: RawUTF8);
var temp: TTextWriterStackBuffer;
begin
with DefaultTextWriterSerializer.CreateOwnedStream(temp) do
try
fCustomOptions := fCustomOptions+Options;
AddTypedJSON(TypeInfo,Value);
SetText(result);
finally
Free;
end;
end;
function SaveJSON(const Value; TypeInfo: pointer; EnumSetsAsText: boolean): RawUTF8;
var options: TTextWriterOptions;
begin
if EnumSetsAsText then
options := [twoEnumSetsAsTextInRecord,twoFullSetsAsStar] else
options := [twoFullSetsAsStar];
SaveJSON(Value,TypeInfo,options,result);
end;
type
/// information about one customized JSON serialization
TJSONCustomParserRegistration = record
RecordTypeName: RawUTF8;
RecordTextDefinition: RawUTF8;
DynArrayTypeInfo: pointer;
RecordTypeInfo: pointer;
Reader: TDynArrayJSONCustomReader;
Writer: TDynArrayJSONCustomWriter;
RecordCustomParser: TJSONRecordAbstract;
end;
PJSONCustomParserRegistration = ^TJSONCustomParserRegistration;
TJSONCustomParserRegistrations = array of TJSONCustomParserRegistration;
PTJSONCustomParserAbstract = ^TJSONRecordAbstract;
/// used internally to manage custom record / dynamic array JSON serialization
// - e.g. used by TTextWriter.RegisterCustomJSONSerializer*()
TJSONCustomParsers = class
protected
fLastDynArrayIndex: integer;
fLastRecordIndex: integer;
fParser: TJSONCustomParserRegistrations;
fParsersCount: Integer;
fParsers: TDynArrayHashed;
{$ifndef NOVARIANTS}
fVariants: array of record
TypeClass: TCustomVariantType;
Reader: TDynArrayJSONCustomReader;
Writer: TDynArrayJSONCustomWriter;
end;
function VariantSearch(aClass: TCustomVariantType): PtrInt;
procedure VariantWrite(aClass: TCustomVariantType;
aWriter: TTextWriter; const aValue: variant; Escape: TTextWriterKind);
{$endif}
function TryToGetFromRTTI(aDynArrayTypeInfo, aRecordTypeInfo: pointer): integer;
function Search(aTypeInfo: pointer; var Reg: TJSONCustomParserRegistration;
AddIfNotExisting: boolean): integer;
function DynArraySearch(aDynArrayTypeInfo, aRecordTypeInfo: pointer;
AddIfNotExisting: boolean=true): integer; overload;
function RecordSearch(aRecordTypeInfo: pointer;
AddIfNotExisting: boolean=true): integer; overload;
function RecordSearch(aRecordTypeInfo: pointer;
out Reader: TDynArrayJSONCustomReader): boolean; overload;
function RecordSearch(aRecordTypeInfo: pointer;
out Writer: TDynArrayJSONCustomWriter; PParser: PTJSONCustomParserAbstract): boolean; overload;
function RecordSearch(const aTypeName: RawUTF8): integer; overload;
function RecordRTTITextHash(aRecordTypeInfo: pointer; var crc: cardinal;
out recsize: integer): boolean;
public
constructor Create;
procedure RegisterCallbacks(aTypeInfo: pointer;
aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter);
function RegisterFromText(aTypeInfo: pointer;
const aRTTIDefinition: RawUTF8): TJSONRecordAbstract;
{$ifndef NOVARIANTS}
procedure RegisterCallbacksVariant(aClass: TCustomVariantType;
aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter);
{$endif}
property Parser: TJSONCustomParserRegistrations read fParser;
property ParsersCount: Integer read fParsersCount;
end;
var
GlobalJSONCustomParsers: TJSONCustomParsers;
constructor TJSONCustomParsers.Create;
begin
fParsers.InitSpecific(TypeInfo(TJSONCustomParserRegistrations),
fParser,djRawUTF8,@fParsersCount,true);
GarbageCollectorFreeAndNil(GlobalJSONCustomParsers,self);
end;
function TJSONCustomParsers.TryToGetFromRTTI(aDynArrayTypeInfo,
aRecordTypeInfo: pointer): integer;
var Reg: TJSONCustomParserRegistration;
RegRoot: TJSONCustomParserRTTI;
{$ifdef ISDELPHI2010}
info: PTypeInfo;
{$endif}
added: boolean;
ndx, len: integer;
name: PShortString;
begin
result := -1;
Reg.RecordTypeInfo := aRecordTypeInfo;
Reg.DynArrayTypeInfo := aDynArrayTypeInfo;
TypeInfoToName(Reg.RecordTypeInfo,Reg.RecordTypeName);
if Reg.RecordTypeName='' then begin
name := TypeInfoToShortString(Reg.DynArrayTypeInfo);
if name=nil then
exit; // we need a type name!
len := length(name^); // try to guess from T*DynArray or T*s names
if (len>12) and (IdemPropName('DynArray',@name^[len-7],8)) then
FastSetString(Reg.RecordTypeName,@name^[1],len-8) else
if (len>3) and (name^[len]='s') then
FastSetString(Reg.RecordTypeName,@name^[1],len-1) else
exit;
end;
RegRoot := TJSONCustomParserRTTI.CreateFromTypeName('',Reg.RecordTypeName);
{$ifdef ISDELPHI2010}
if RegRoot=nil then begin
info := GetTypeInfo(aRecordTypeInfo,tkRecordKinds);
if info=nil then
exit; // not enough RTTI
inc(PByte(info),info^.ManagedCount*SizeOf(TFieldInfo)-SizeOf(TFieldInfo));
inc(PByte(info),info^.NumOps*SizeOf(pointer)); // jump RecOps[]
if info^.AllCount=0 then
exit; // not enough RTTI -> avoid exception in constructor below
end;
{$else}
if RegRoot=nil then
exit; // not enough RTTI for older versions of Delphi
{$endif}
Reg.RecordCustomParser := TJSONRecordRTTI.Create(Reg.RecordTypeInfo,RegRoot);
Reg.Reader := Reg.RecordCustomParser.CustomReader;
Reg.Writer := Reg.RecordCustomParser.CustomWriter;
if self=nil then
if GlobalJSONCustomParsers<>nil then // may have been set just above
self := GlobalJSONCustomParsers else
self := TJSONCustomParsers.Create;
ndx := fParsers.FindHashedForAdding(Reg.RecordTypeName,added);
if not added then
exit; // name should be unique
fParser[ndx] := Reg;
result := ndx;
end;
function TJSONCustomParsers.DynArraySearch(aDynArrayTypeInfo,aRecordTypeInfo: pointer;
AddIfNotExisting: boolean): Integer;
var threadsafe: integer;
parser: PJSONCustomParserRegistration;
begin // O(n) brute force is fast enough, since n remains small (mostly<64)
if self<>nil then
if (aDynArrayTypeInfo<>nil) and (fParsersCount<>0) then begin
threadsafe := fLastDynArrayIndex;
if (cardinal(threadsafe)<cardinal(fParsersCount)) and
(fParser[threadsafe].DynArrayTypeInfo=aDynArrayTypeInfo) then begin
result := threadsafe;
exit;
end else begin
if aRecordTypeInfo=nil then // record RTTI not specified: guess now
aRecordTypeInfo := DynArrayTypeInfoToRecordInfo(aDynArrayTypeInfo);
if aRecordTypeInfo=nil then begin
parser := pointer(fParser);
for result := 0 to fParsersCount-1 do
if parser^.DynArrayTypeInfo=aDynArrayTypeInfo then begin
fLastDynArrayIndex := result;
exit;
end else
inc(parser);
end else begin
threadsafe := fLastRecordIndex;
if (cardinal(threadsafe)<cardinal(fParsersCount)) and
(fParser[threadsafe].RecordTypeInfo=aRecordTypeInfo) then begin
result := threadsafe;
exit;
end else begin
parser := pointer(fParser);
for result := 0 to fParsersCount-1 do
if (parser^.DynArrayTypeInfo=aDynArrayTypeInfo) or
(parser^.RecordTypeInfo=aRecordTypeInfo) then begin
fLastDynArrayIndex := result;
fLastRecordIndex := result;
exit;
end else
inc(parser);
end;
end;
end;
end;
if AddIfNotExisting then begin
result := TryToGetFromRTTI(aDynArrayTypeInfo,aRecordTypeInfo);
if result>=0 then
fLastRecordIndex := result;
end else
result := -1;
end;
function TJSONCustomParsers.RecordSearch(aRecordTypeInfo: pointer;
AddIfNotExisting: boolean): integer;
begin
if aRecordTypeInfo=nil then begin
result := -1;
exit;
end;
if self<>nil then
if (cardinal(fLastRecordIndex)<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
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(fParser[ndx].Reader) then begin
Reader := fParser[ndx].Reader;
result := true;
end else
result := false;
end;
function TJSONCustomParsers.RecordRTTITextHash(aRecordTypeInfo: pointer;
var crc: cardinal; out recsize: integer): boolean;
var ndx: integer;
begin
if (self<>nil) and (aRecordTypeInfo<>nil) then
for ndx := 0 to fParsersCount-1 do
with fParser[ndx] do
if RecordTypeInfo=aRecordTypeInfo then begin
if RecordTextDefinition='' then
break;
crc := crc32c(crc,pointer(RecordTextDefinition),length(RecordTextDefinition));
recsize := RecordTypeInfoSize(aRecordTypeInfo);
result := true;
exit;
end;
result := false;
end;
function TJSONCustomParsers.RecordSearch(aRecordTypeInfo: pointer;
out Writer: TDynArrayJSONCustomWriter; PParser: PTJSONCustomParserAbstract): boolean;
var ndx: integer;
begin
result := false;
ndx := RecordSearch(aRecordTypeInfo);
if (ndx>=0) and Assigned(fParser[ndx].Writer) then begin
Writer := fParser[ndx].Writer;
if PParser<>nil then
PParser^ := fParser[ndx].RecordCustomParser;
result := true;
end;
end;
function TJSONCustomParsers.Search(aTypeInfo: pointer;
var Reg: TJSONCustomParserRegistration; AddIfNotExisting: boolean): integer;
var added: boolean;
begin
if (aTypeInfo=nil) or (self=nil) then
raise ESynException.CreateUTF8('%.Search(%)',[self,aTypeInfo]);
FillCharFast(Reg,SizeOf(Reg),0);
case PTypeKind(aTypeInfo)^ of
tkDynArray: begin
Reg.DynArrayTypeInfo := aTypeInfo;
Reg.RecordTypeInfo := DynArrayTypeInfoToRecordInfo(aTypeInfo);
result := DynArraySearch(Reg.DynArrayTypeInfo,Reg.RecordTypeInfo,false);
end;
tkRecord{$ifdef FPC},tkObject{$endif}: begin
Reg.DynArrayTypeInfo := nil;
Reg.RecordTypeInfo := aTypeInfo;
result := RecordSearch(Reg.RecordTypeInfo,false);
end;
else raise ESynException.CreateUTF8('%.Search: % not a tkDynArray/tkRecord',
[self,ToText(PTypeKind(aTypeInfo)^)^]);
end;
if not AddIfNotExisting then
exit;
TypeInfoToName(Reg.RecordTypeInfo,Reg.RecordTypeName);
if Reg.RecordTypeName='' then
TypeInfoToName(Reg.DynArrayTypeInfo,Reg.RecordTypeName);
if Reg.RecordTypeName='' then
raise ESynException.CreateUTF8('%.Search(%) has no type name',[self,aTypeInfo]);
if result<0 then
result := fParsers.FindHashedForAdding(Reg.RecordTypeName,added);
end;
{$ifndef NOVARIANTS}
function TJSONCustomParsers.VariantSearch(aClass: TCustomVariantType): PtrInt;
begin
if self<>nil then
for result := 0 to length(fVariants)-1 do
if fVariants[result].TypeClass=aClass then
exit;
result := -1;
end;
procedure TJSONCustomParsers.VariantWrite(aClass: TCustomVariantType;
aWriter: TTextWriter; const aValue: variant; Escape: TTextWriterKind);
var ndx: PtrInt;
temp: string;
begin
ndx := VariantSearch(aClass);
if (ndx>=0) and Assigned(fVariants[ndx].Writer) then
fVariants[ndx].Writer(aWriter,aValue) else begin
temp := aValue; // fallback to JSON string from variant-to-string conversion
if Escape=twJSONEscape then
aWriter.Add('"');
{$ifdef UNICODE}
aWriter.AddW(pointer(temp),length(temp),Escape);
{$else}
aWriter.AddAnsiString(temp,Escape);
{$endif}
if Escape=twJSONEscape then
aWriter.Add('"');
end;
end;
procedure TJSONCustomParsers.RegisterCallbacksVariant(aClass: TCustomVariantType;
aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter);
var ndx: PtrInt;
begin
if self=nil then
self := TJSONCustomParsers.Create;
ndx := VariantSearch(aClass);
if ndx<0 then begin
ndx := length(fVariants);
SetLength(fVariants,ndx+1);
fVariants[ndx].TypeClass := aClass;
end;
fVariants[ndx].Writer := aWriter;
fVariants[ndx].Reader := aReader;
end;
{$endif}
procedure TJSONCustomParsers.RegisterCallbacks(aTypeInfo: pointer;
aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter);
var Reg: TJSONCustomParserRegistration;
ForAdding: boolean;
ndx: integer;
begin
if self=nil then
self := TJSONCustomParsers.Create;
ForAdding := Assigned(aReader) or Assigned(aWriter);
ndx := Search(aTypeInfo,Reg,ForAdding);
if ForAdding then begin
Reg.Writer := aWriter;
Reg.Reader := aReader;
fParser[ndx] := Reg;
end else
if ndx>=0 then begin
fParsers.Delete(ndx);
fParsers.ReHash;
end;
end;
function TJSONCustomParsers.RegisterFromText(aTypeInfo: pointer;
const aRTTIDefinition: RawUTF8): TJSONRecordAbstract;
var Reg: TJSONCustomParserRegistration;
ForAdding: boolean;
ndx: integer;
begin
if self=nil then
self := TJSONCustomParsers.Create;
ForAdding := aRTTIDefinition<>'';
ndx := Search(aTypeInfo,Reg,ForAdding);
if ForAdding then begin
result := TJSONRecordTextDefinition.FromCache(Reg.RecordTypeInfo,aRTTIDefinition);
Reg.RecordTextDefinition := aRTTIDefinition;
Reg.Reader := result.CustomReader;
Reg.Writer := result.CustomWriter;
Reg.RecordCustomParser := result;
fParser[ndx] := Reg;
end else begin
result := nil;
if ndx>=0 then begin
fParsers.Delete(ndx);
fParsers.ReHash;
end;
end;
end;
function ManagedTypeSaveRTTIHash(info: PTypeInfo; var crc: cardinal): integer;
var itemtype: PTypeInfo;
i, unmanagedsize: integer;
field: PFieldInfo;
dynarray: TDynArray;
begin // info is expected to come from a DeRef() if retrieved from RTTI
result := 0;
if info=nil then
exit;
{$ifdef FPC} // storage binary layout as Delphi's ordinal value
crc := crc32c(crc,@FPCTODELPHI[info^.Kind],1);
{$else}
crc := crc32c(crc,@info^.Kind,1); // hash RTTI kind, but not name
{$endif}
case info^.Kind of // handle nested RTTI
tkLString,{$ifdef FPC}tkLStringOld,{$endif}{$ifdef HASVARUSTRING}tkUString,{$endif}
tkWString,tkInterface:
result := SizeOf(pointer);
{$ifndef NOVARIANTS}
tkVariant:
result := SizeOf(variant);
{$endif}
tkRecord{$ifdef FPC},tkObject{$endif}: // first search from custom RTTI text
if not GlobalJSONCustomParsers.RecordRTTITextHash(info,crc,result) then begin
itemtype := GetTypeInfo(info,tkRecordKinds);
if itemtype<>nil then begin
unmanagedsize := itemtype^.recsize;
for i := 1 to GetManagedFields(itemtype,field) do begin
info := DeRef(field^.TypeInfo);
{$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields
if info^.Kind in tkManagedTypes then // as with Delphi
{$endif}
dec(unmanagedsize,ManagedTypeSaveRTTIHash(info,crc));
inc(field);
end;
crc := crc32c(crc,@unmanagedsize,4);
result := itemtype^.recSize;
end;
end;
tkArray: begin
itemtype := ArrayItemType(info,result);
if info=nil then
exit;
unmanagedsize := result;
if itemtype<>nil then
for i := 1 to info^.elCount do
dec(unmanagedsize,ManagedTypeSaveRTTIHash(itemtype,crc));
crc := crc32c(crc,@unmanagedsize,4);
end;
tkDynArray: begin
dynarray.Init(info,field); // fake void array pointer
crc := dynarray.SaveToTypeInfoHash(crc);
result := SizeOf(pointer);
end;
end;
end;
function TypeInfoToHash(aTypeInfo: pointer): cardinal;
begin
result := 0;
ManagedTypeSaveRTTIHash(aTypeInfo,result);
end;
function RecordSaveJSON(const Rec; TypeInfo: pointer; EnumSetsAsText: boolean): RawUTF8;
begin
result := SaveJSON(Rec,TypeInfo,EnumSetsAsText);
end;
const
NULCHAR: AnsiChar = #0;
function RecordLoadJSON(var Rec; JSON: PUTF8Char; TypeInfo: pointer; EndOfObject: PUTF8Char
{$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char;
var wasString, wasValid: boolean;
Reader: TDynArrayJSONCustomReader;
FirstChar,EndOfObj: AnsiChar;
Val: PUTF8Char;
ValLen: integer;
begin // code below must match TTextWriter.AddRecordJSON
result := nil; // indicates error
if JSON=nil then
exit;
if (@Rec=nil) or (TypeInfo=nil) then
raise ESynException.CreateUTF8('Invalid RecordLoadJSON(%) call',[TypeInfo]);
if JSON^=' ' then repeat inc(JSON); if JSON^=#0 then exit; until JSON^<>' ';
if PCardinal(JSON)^=JSON_BASE64_MAGIC_QUOTE then begin
if not (PTypeKind(TypeInfo)^ in tkRecordTypes) then
raise ESynException.CreateUTF8('RecordLoadJSON(%/%)',
[PShortString(@PTypeInfo(TypeInfo).NameLen)^,ToText(PTypeKind(TypeInfo)^)^]);
Val := GetJSONField(JSON,JSON,@wasString,@EndOfObj,@ValLen);
if (Val=nil) or not wasString or (ValLen<3) or
(PInteger(Val)^ and $00ffffff<>JSON_BASE64_MAGIC) or
not RecordLoad(Rec,Base64ToBin(PAnsiChar(Val)+3,ValLen-3),TypeInfo) then
exit; // invalid content
end else begin
if not GlobalJSONCustomParsers.RecordSearch(TypeInfo,Reader) then
exit;
FirstChar := JSON^;
JSON := Reader(JSON,Rec,wasValid{$ifndef NOVARIANTS},CustomVariantOptions{$endif});
if not wasValid then
exit;
if JSON<>nil then
JSON := GotoNextNotSpace(JSON);
if (JSON<>nil) and (JSON^<>#0) then
if FirstChar='"' then // special case e.g. for TGUID string
EndOfObj := FirstChar else begin
EndOfObj := JSON^;
inc(JSON);
end else
EndOfObj := #0;
end;
if JSON=nil then // end reached, but valid content decoded
result := @NULCHAR else
result := JSON;
if EndOfObject<>nil then
EndOfObject^ := EndOfObj;
end;
function RecordLoadJSON(var Rec; const JSON: RawUTF8; TypeInfo: pointer{$ifndef NOVARIANTS};
CustomVariantOptions: PDocVariantOptions{$endif}): boolean;
var tmp: TSynTempBuffer;
begin
tmp.Init(JSON); // make private copy before in-place decoding
try
result := RecordLoadJSON(Rec,tmp.buf,TypeInfo,nil
{$ifndef NOVARIANTS},CustomVariantOptions{$endif})<>nil;
finally
tmp.Done;
end;
end;
{ TJSONCustomParserCustom }
constructor TJSONCustomParserCustom.Create(const aPropertyName, aCustomTypeName: RawUTF8);
begin
inherited Create(aPropertyName,ptCustom);
fCustomTypeName := aCustomTypeName;
end;
procedure TJSONCustomParserCustom.FinalizeItem(Data: Pointer);
begin // nothing to be done by default
end;
{ TJSONCustomParserCustomSimple }
constructor TJSONCustomParserCustomSimple.Create(
const aPropertyName, aCustomTypeName: RawUTF8; aCustomType: pointer);
var info: PTypeInfo;
kind: TTypeKind;
begin
inherited Create(aPropertyName,aCustomTypeName);
fCustomTypeInfo := aCustomType;
if IdemPropNameU(aCustomTypeName,'TGUID') then begin
fKnownType := ktGUID;
fDataSize := SizeOf(TGUID);
end else
if fCustomTypeInfo<>nil then begin
TypeInfoToName(fCustomTypeInfo,fCustomTypeName,aCustomTypeName);
kind := PTypeKind(fCustomTypeInfo)^;
info := GetTypeInfo(fCustomTypeInfo,[tkEnumeration,tkSet,tkArray,tkDynArray]);
fTypeData := info;
if info<>nil then
case kind of
tkEnumeration, tkSet: begin
fDataSize := ORDTYPE_SIZE[info^.EnumType];
if kind=tkEnumeration then
fKnownType := ktEnumeration else
fKnownType := ktSet;
exit; // success
end;
tkArray: begin
if info^.dimCount<>1 then
raise ESynException.CreateUTF8('%.Create("%") supports only single '+
'dimension static array)',[self,fCustomTypeName]);
fKnownType := ktStaticArray;
{$ifdef VER2_6}
fFixedSize := info^.arraySize; // is elSize in fact
fDataSize := fFixedSize*info^.elCount;
{$else}
fDataSize := info^.arraySize;
fFixedSize := fDataSize div info^.elCount;
{$endif}
fNestedArray := TJSONCustomParserRTTI.CreateFromRTTI(
'',Deref(info^.arrayType),fFixedSize);
exit; // success
end;
tkDynArray: begin
fKnownType := ktDynamicArray;
exit; // success
end;
end;
raise ESynException.CreateUTF8('%.Create("%") unsupported type: % (%)',
[self,fCustomTypeName,ToText(kind)^,ord(kind)]);
end;
end;
constructor TJSONCustomParserCustomSimple.CreateFixedArray(
const aPropertyName: RawUTF8; aFixedSize: cardinal);
begin
inherited Create(aPropertyName,FormatUTF8('Fixed%Byte',[aFixedSize]));
fKnownType := ktFixedArray;
fFixedSize := aFixedSize;
fDataSize := aFixedSize;
end;
constructor TJSONCustomParserCustomSimple.CreateBinary(
const aPropertyName: RawUTF8; aDataSize, aFixedSize: cardinal);
begin
inherited Create(aPropertyName,FormatUTF8('BinHex%Byte',[aFixedSize]));
fKnownType := ktBinary;
fFixedSize := aFixedSize;
fDataSize := aDataSize;
end;
destructor TJSONCustomParserCustomSimple.Destroy;
begin
inherited;
fNestedArray.Free;
end;
procedure TJSONCustomParserCustomSimple.CustomWriter(
const aWriter: TTextWriter; const aValue);
var i: integer;
V: PByte;
begin
case fKnownType of
ktStaticArray: begin
aWriter.Add('[');
V := @aValue;
for i := 1 to PTypeInfo(fTypeData)^.elCount do begin
fNestedArray.WriteOneLevel(aWriter,V,[]);
aWriter.Add(',');
end;
aWriter.CancelLastComma;
aWriter.Add(']');
end;
ktEnumeration, ktSet:
aWriter.AddTypedJSON(fCustomTypeInfo,aValue);
ktDynamicArray:
raise ESynException.CreateUTF8('%.CustomWriter("%"): unsupported',
[self,fCustomTypeName]);
ktBinary:
if (fFixedSize<=SizeOf(QWord)) and IsZero(@aValue,fFixedSize) then
aWriter.AddShort('""') else // 0 -> ""
aWriter.AddBinToHexDisplayQuoted(@aValue,fFixedSize);
else begin // encoded as JSON strings
aWriter.Add('"');
case fKnownType of
ktGUID:
aWriter.Add(TGUID(aValue));
ktFixedArray:
aWriter.AddBinToHex(@aValue,fFixedSize);
end;
aWriter.Add('"');
end;
end;
end;
function TJSONCustomParserCustomSimple.CustomReader(P: PUTF8Char; var aValue;
out EndOfObject: AnsiChar{$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char;
var PropValue: PUTF8Char;
i, PropValueLen, i32: integer;
u64: QWord;
wasString: boolean;
Val: PByte;
begin
result := nil; // indicates error
case fKnownType of
ktStaticArray: begin
if P^<>'[' then
exit; // we expect a true array here
P := GotoNextNotSpace(P+1);
if JSONArrayCount(P)<>PTypeInfo(fTypeData)^.elCount then
exit; // invalid number of items
Val := @aValue;
for i := 1 to PTypeInfo(fTypeData)^.elCount do
if not fNestedArray.ReadOneLevel(
P,Val,[]{$ifndef NOVARIANTS},CustomVariantOptions{$endif}) then
exit else
if P=nil then
exit;
P := GotoNextNotSpace(P);
EndOfObject := P^;
if P^ in [',','}'] then
inc(P);
result := P;
end;
ktDynamicArray:
raise ESynException.CreateUTF8('%.CustomReader("%"): unsupported',
[self,fCustomTypeName]);
ktSet: begin
i32 := GetSetNameValue(fCustomTypeInfo,P,EndOfObject);
MoveSmall(@i32,@aValue,fDataSize);
result := P;
end;
else begin // encoded as JSON strings or number
PropValue := GetJSONField(P,P,@wasString,@EndOfObject,@PropValueLen);
if PropValue=nil then
exit; // not a JSON string or number
if P=nil then // result=nil=error + caller may dec(P); P^:=EndOfObject;
P := PropValue+PropValueLen;
case fKnownType of
ktGUID:
if wasString and (TextToGUID(PropValue,@aValue)<>nil) then
result := P;
ktEnumeration: begin
if wasString then
i32 := GetEnumNameValue(fCustomTypeInfo,PropValue,PropValueLen,true) else
i32 := GetCardinal(PropValue);
if i32<0 then
exit;
MoveSmall(@i32,@aValue,fDataSize);
result := P;
end;
ktFixedArray:
if wasString and (PropValueLen=fFixedSize*2) and
SynCommons.HexToBin(PAnsiChar(PropValue),@aValue,fFixedSize) then
result := P;
ktBinary:
if wasString then begin // default hexa serialization
FillCharFast(aValue,fDataSize,0);
if (PropValueLen=0) or ((PropValueLen=fFixedSize*2) and
HexDisplayToBin(PAnsiChar(PropValue),@aValue,fFixedSize)) then
result := P;
end else
if fFixedSize<=SizeOf(u64) then begin // allow integer serialization
SetQWord(PropValue,u64);
MoveSmall(@u64,@aValue,fDataSize);
result := P;
end;
end;
end;
end;
end;
{ TJSONCustomParserCustomRecord }
constructor TJSONCustomParserCustomRecord.Create(
const aPropertyName: RawUTF8; aCustomTypeIndex: integer);
begin
fCustomTypeIndex := aCustomTypeIndex;
with GlobalJSONCustomParsers.fParser[fCustomTypeIndex] do begin
inherited Create(aPropertyName,RecordTypeName);
fCustomTypeInfo := RecordTypeInfo;
fCustomTypeName := RecordTypeName;
end;
fDataSize := RecordTypeInfoSize(fCustomTypeInfo);
end;
function TJSONCustomParserCustomRecord.GetJSONCustomParserRegistration: pointer;
begin
result := nil;
if GlobalJSONCustomParsers<>nil then begin
if (Cardinal(fCustomTypeIndex)>=Cardinal(GlobalJSONCustomParsers.fParsersCount)) or
not IdemPropNameU(fCustomTypeName,
GlobalJSONCustomParsers.fParser[fCustomTypeIndex].RecordTypeName) then
fCustomTypeIndex := GlobalJSONCustomParsers.RecordSearch(fCustomTypeInfo);
if fCustomTypeIndex>=0 then
result := @GlobalJSONCustomParsers.fParser[fCustomTypeIndex];
end;
if result=nil then
raise ESynException.CreateUTF8(
'%: [%] type should not have been un-registered',[self,fCustomTypeName]);
end;
procedure TJSONCustomParserCustomRecord.CustomWriter(
const aWriter: TTextWriter; const aValue);
var parser: PJSONCustomParserRegistration;
begin
parser := GetJSONCustomParserRegistration;
parser^.Writer(aWriter,aValue);
end;
function TJSONCustomParserCustomRecord.CustomReader(P: PUTF8Char; var aValue;
out EndOfObject: AnsiChar{$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char;
var valid: boolean;
callback: PJSONCustomParserRegistration; // D5/D6 Internal error: C3890
begin
callback := GetJSONCustomParserRegistration;
result := callback^.Reader(P,aValue,valid{$ifndef NOVARIANTS},CustomVariantOptions{$endif});
if not valid then
result := nil;
if result=nil then
exit;
EndOfObject := result^;
if result^ in [',','}',']'] then
inc(result);
end;
procedure TJSONCustomParserCustomRecord.FinalizeItem(Data: Pointer);
begin
RecordClear(Data^,fCustomTypeInfo);
end;
{ TJSONCustomParserRTTI }
type
TJSONSerializerFromTextSimple = record
TypeInfo: pointer;
BinaryDataSize, BinaryFieldSize: integer;
end;
TJSONSerializerFromTextSimpleDynArray = array of TJSONSerializerFromTextSimple;
var // RawUTF8/TJSONSerializerFromTextSimpleDynArray
GlobalCustomJSONSerializerFromTextSimpleType: TSynDictionary;
procedure JSONSerializerFromTextSimpleTypeAdd(aTypeName: RawUTF8;
aTypeInfo: pointer; aDataSize, aFieldSize: integer);
var simple: TJSONSerializerFromTextSimple;
begin
if aTypeName='' then
TypeInfoToName(aTypeInfo,aTypeName);
if aDataSize<>0 then
if aFieldSize>aDataSize then
raise ESynException.CreateUTF8('JSONSerializerFromTextSimpleTypeAdd(%) fieldsize=%>%',
[aTypeName,aFieldSize,aDataSize]) else
if aFieldSize=0 then
aFieldSize := aDataSize; // not truncated
simple.TypeInfo := aTypeInfo;
simple.BinaryDataSize := aDataSize;
simple.BinaryFieldSize := aFieldSize;
UpperCaseSelf(aTypeName);
if GlobalCustomJSONSerializerFromTextSimpleType.Add(aTypeName,simple)<0 then
raise ESynException.CreateUTF8('JSONSerializerFromTextSimpleTypeAdd(%) duplicated', [aTypeName]);
end;
/// if defined, will try to mimic the default record alignment
// -> is buggy, and compiler revision specific -> we would rather use packed records
{.$define ALIGNCUSTOMREC}
constructor TJSONCustomParserRTTI.Create(const aPropertyName: RawUTF8;
aPropertyType: TJSONCustomParserRTTIType);
begin
fPropertyName := aPropertyName;
fPropertyType := aPropertyType;
end;
class function TJSONCustomParserRTTI.TypeNameToSimpleRTTIType(TypeName: PUTF8Char;
TypeNameLen: PtrInt; ItemTypeName: PRawUTF8): TJSONCustomParserRTTIType;
const
SORTEDMAX = {$ifdef NOVARIANTS}32{$else}33{$endif}{$ifdef HASVARUSTRING}+1{$endif};
SORTEDNAMES: array[0..SORTEDMAX] of PUTF8Char =
('ARRAY','BOOLEAN','BYTE','CARDINAL','CURRENCY',
'DOUBLE','EXTENDED','INT64','INTEGER','PTRINT','PTRUINT','QWORD',
'RAWBYTESTRING','RAWJSON','RAWUTF8','RECORD','SINGLE',
'STRING','SYNUNICODE','TCREATETIME','TDATETIME','TDATETIMEMS','TGUID',
'TID','TMODTIME','TRECORDREFERENCE','TRECORDREFERENCETOBEDELETED',
'TRECORDVERSION','TSQLRAWBLOB','TTIMELOG',{$ifdef HASVARUSTRING}'UNICODESTRING',{$endif}
'UTF8STRING',{$ifndef NOVARIANTS}'VARIANT',{$endif}
'WIDESTRING','WORD');
// warning: recognized types should match at binary storage level!
SORTEDTYPES: array[0..SORTEDMAX] of TJSONCustomParserRTTIType =
(ptArray,ptBoolean,ptByte,ptCardinal,ptCurrency,
ptDouble,ptExtended,ptInt64,ptInteger,ptPtrInt,ptPtrUInt,ptQWord,
ptRawByteString,ptRawJSON,ptRawUTF8,ptRecord,ptSingle,
ptString,ptSynUnicode,ptTimeLog,ptDateTime,ptDateTimeMS,ptGUID,
ptID,ptTimeLog,ptInt64,ptInt64,ptInt64,ptRawByteString,ptTimeLog,
{$ifdef HASVARUSTRING}ptUnicodeString,{$endif}ptRawUTF8,
{$ifndef NOVARIANTS}ptVariant,{$endif}
ptWideString,ptWord);
var ndx: integer;
up: PUTF8Char;
tmp: array[byte] of AnsiChar; // avoid unneeded memory allocation
begin
if ItemTypeName<>nil then begin
UpperCaseCopy(TypeName,TypeNameLen,ItemTypeName^);
up := pointer(ItemTypeName^);
end else begin
UpperCopy255Buf(@tmp,TypeName,TypeNameLen)^ := #0;
up := @tmp;
end;
//for ndx := 1 to SORTEDMAX do assert(StrComp(SORTEDNAMES[ndx],SORTEDNAMES[ndx-1])>0,SORTEDNAMES[ndx]);
ndx := FastFindPUTF8CharSorted(@SORTEDNAMES,SORTEDMAX,up);
if ndx>=0 then
result := SORTEDTYPES[ndx] else
result := ptCustom;
end;
class function TJSONCustomParserRTTI.TypeNameToSimpleRTTIType(
const TypeName: RawUTF8): TJSONCustomParserRTTIType;
begin
if TypeName='' then
result := ptCustom else
result := TypeNameToSimpleRTTIType(Pointer(TypeName),length(TypeName),nil);
end;
class function TJSONCustomParserRTTI.TypeNameToSimpleRTTIType(
TypeName: PShortString): TJSONCustomParserRTTIType;
begin
if TypeName=nil then
result := ptCustom else
result := TypeNameToSimpleRTTIType(@TypeName^[1],ord(TypeName^[0]),nil);
end;
class function TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(Info: pointer): TJSONCustomParserRTTIType;
begin
result := ptCustom; // e.g. for tkRecord
if Info=nil then
exit;
case PTypeKind(Info)^ of // FPC and Delphi will use a fast jmp table
tkLString{$ifdef FPC},tkLStringOld{$endif}: result := ptRawUTF8;
tkWString: result := ptWideString;
{$ifdef HASVARUSTRING}tkUString: result := ptUnicodeString;{$endif}
{$ifdef FPC_OR_UNICODE}
tkClassRef,tkPointer{$ifdef UNICODE},tkProcedure{$endif}: result := ptPtrInt;
{$endif}
{$ifndef NOVARIANTS}
tkVariant: result := ptVariant;
{$endif}
tkDynArray: result := ptArray;
tkChar: result := ptByte;
tkWChar: result := ptWord;
tkClass, tkMethod, tkInterface: result := ptPtrInt;
tkInteger:
case GetTypeInfo(Info)^.IntegerType of
otSByte,otUByte: result := ptByte;
otSWord,otUWord: result := ptWord;
otSLong: result := ptInteger;
otULong: result := ptCardinal;
{$ifdef FPC_NEWRTTI}
otSQWord: result := ptInt64;
otUQWord: result := ptQWord;
{$endif}
end;
tkInt64:
{$ifndef FPC} if Info=TypeInfo(QWord) then result := ptQWord else
{$ifdef UNICODE}with GetTypeInfo(Info)^ do // detect QWord/UInt64
if MinInt64Value>MaxInt64Value then result := ptQWord else{$endif}{$endif}
result := ptInt64;
{$ifdef FPC}
tkQWord: result := ptQWord;
tkBool: result := ptBoolean;
{$else}
tkEnumeration: // other enumerates (or tkSet) use TJSONCustomParserCustomSimple
if Info=TypeInfo(boolean) then
result := ptBoolean;
{$endif}
tkFloat:
case GetTypeInfo(Info)^.FloatType of
ftSingle: result := ptSingle;
ftDoub: result := ptDouble;
ftCurr: result := ptCurrency;
ftExtended: result := ptExtended;
// ftComp: not implemented yet
end;
end;
end;
function TypeInfoToRttiType(aTypeInfo: pointer): TJSONCustomParserRTTIType;
begin // first by known name, then from RTTI
result := TJSONCustomParserRTTI.TypeNameToSimpleRTTIType(
PUTF8Char(@PTypeInfo(aTypeInfo)^.NameLen)+1,PTypeInfo(aTypeInfo)^.NameLen,nil);
if result=ptCustom then
result := TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(aTypeInfo);
end;
class function TJSONCustomParserRTTI.TypeNameToSimpleBinary(const aTypeName: RawUTF8;
out aDataSize, aFieldSize: integer): boolean;
var simple: ^TJSONSerializerFromTextSimple;
begin
simple := GlobalCustomJSONSerializerFromTextSimpleType.FindValue(aTypeName);
if (simple<>nil) and (simple^.BinaryFieldSize<>0) then begin
aDataSize := simple^.BinaryDataSize;
aFieldSize := simple^.BinaryFieldSize;
result := true;
end else
result := false;
end;
class function TJSONCustomParserRTTI.CreateFromRTTI(
const PropertyName: RawUTF8; Info: pointer; ItemSize: integer): TJSONCustomParserRTTI;
var Item: PTypeInfo absolute Info;
ItemType: TJSONCustomParserRTTIType;
ItemTypeName: RawUTF8;
ndx: integer;
begin
if Item=nil then // no RTTI -> stored as hexa string
result := TJSONCustomParserCustomSimple.CreateFixedArray(PropertyName,ItemSize) else begin
ItemType := TypeNameToSimpleRTTIType(PUTF8Char(@Item.NameLen)+1,Item.NameLen,@ItemTypeName);
if ItemType=ptCustom then
ItemType := TypeInfoToSimpleRTTIType(Info);
if ItemType=ptCustom then
if Item^.kind in [tkEnumeration,tkArray,tkDynArray,tkSet] then
result := TJSONCustomParserCustomSimple.Create(
PropertyName,ItemTypeName,Item) else begin
ndx := GlobalJSONCustomParsers.RecordSearch(Item);
if ndx<0 then
ndx := GlobalJSONCustomParsers.RecordSearch(ItemTypeName);
if ndx<0 then
raise ESynException.CreateUTF8('%.CreateFromRTTI("%") unsupported %',
[self,ItemTypeName,ToText(Item^.kind)^]);
result := TJSONCustomParserCustomRecord.Create(PropertyName,ndx);
end else
result := TJSONCustomParserRTTI.Create(PropertyName,ItemType);
end;
if ItemSize<>0 then
result.fDataSize := ItemSize;
end;
class function TJSONCustomParserRTTI.CreateFromTypeName(
const aPropertyName, aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI;
var ndx: integer;
simple: ^TJSONSerializerFromTextSimple;
begin
simple := GlobalCustomJSONSerializerFromTextSimpleType.FindValue(aCustomRecordTypeName);
if simple<>nil then
if simple^.BinaryFieldSize<>0 then
result := TJSONCustomParserCustomSimple.CreateBinary(
aPropertyName,simple^.BinaryDataSize,simple^.BinaryFieldSize) else
result := TJSONCustomParserCustomSimple.Create(
aPropertyName,aCustomRecordTypeName,simple^.TypeInfo) else begin
ndx := GlobalJSONCustomParsers.RecordSearch(aCustomRecordTypeName);
if ndx<0 then
result := nil else
result := TJSONCustomParserCustomRecord.Create(aPropertyName,ndx);
end;
end;
procedure TJSONCustomParserRTTI.ComputeFullPropertyName;
var i: PtrInt;
begin
for i := 0 to length(NestedProperty)-1 do begin
NestedProperty[i].ComputeFullPropertyName;
if fFullPropertyName<>'' then
NestedProperty[i].fFullPropertyName :=
fFullPropertyName+'.'+NestedProperty[i].fPropertyName;
end;
end;
procedure TJSONCustomParserRTTI.ComputeNestedDataSize;
var i: PtrInt;
begin
assert(fNestedDataSize=0);
fNestedDataSize := 0;
for i := 0 to length(NestedProperty)-1 do begin
NestedProperty[i].ComputeDataSizeAfterAdd;
inc(fNestedDataSize,NestedProperty[i].fDataSize);
if fFullPropertyName<>'' then
NestedProperty[i].fFullPropertyName :=
fFullPropertyName+'.'+NestedProperty[i].fPropertyName;
end;
end;
procedure TJSONCustomParserRTTI.ComputeDataSizeAfterAdd;
const // binary size (in bytes) of each kind of property - 0 for ptRecord/ptCustom
JSONRTTI_SIZE: array[TJSONCustomParserRTTIType] of byte = (
SizeOf(PtrUInt),SizeOf(Boolean),SizeOf(Byte),SizeOf(Cardinal),SizeOf(Currency),
SizeOf(Double),SizeOf(Extended),SizeOf(Int64),SizeOf(Integer),SizeOf(QWord),
SizeOf(RawByteString),SizeOf(RawJSON),SizeOf(RawUTF8),0,SizeOf(Single),
SizeOf(String),SizeOf(SynUnicode),SizeOf(TDateTime),SizeOf(TDateTimeMS),
SizeOf(TGUID),SizeOf(Int64),SizeOf(TTimeLog),
{$ifdef HASVARUSTRING}SizeOf(UnicodeString),{$endif}
{$ifndef NOVARIANTS}SizeOf(Variant),{$endif}
SizeOf(WideString),SizeOf(Word),0);
var i: PtrInt;
begin
if fFullPropertyName='' then begin
fFullPropertyName := fPropertyName;
ComputeFullPropertyName;
end;
if fDataSize=0 then begin
ComputeNestedDataSize;
case PropertyType of
ptRecord:
for i := 0 to length(NestedProperty)-1 do
inc(fDataSize,NestedProperty[i].fDataSize);
//ptCustom: fDataSize already set in TJSONCustomParserCustom.Create()
else
fDataSize := JSONRTTI_SIZE[PropertyType];
end;
{$ifdef ALIGNCUSTOMREC}
inc(fDataSize,fDataSize and 7);
{$endif}
end;
end;
procedure TJSONCustomParserRTTI.FinalizeNestedRecord(var Data: PByte);
var j: PtrInt;
begin
for j := 0 to length(NestedProperty)-1 do begin
case NestedProperty[j].PropertyType of
ptRawByteString,
ptRawJSON,
ptRawUTF8: {$ifdef FPC}Finalize(PRawByteString(Data)^){$else}PRawByteString(Data)^ := ''{$endif};
ptString: PString(Data)^ := '';
ptSynUnicode: PSynUnicode(Data)^ := '';
{$ifdef HASVARUSTRING}
ptUnicodeString: PUnicodeString(Data)^ := '';
{$endif}
ptWideString: PWideString(Data)^ := '';
ptArray: NestedProperty[j].FinalizeNestedArray(PPtrUInt(Data)^);
{$ifndef NOVARIANTS}
ptVariant: VarClear(PVariant(Data)^);
{$endif}
ptRecord: begin
NestedProperty[j].FinalizeNestedRecord(Data);
continue;
end;
ptCustom:
TJSONCustomParserCustom(NestedProperty[j]).FinalizeItem(Data);
end;
inc(Data,NestedProperty[j].fDataSize);
end;
end;
procedure TJSONCustomParserRTTI.FinalizeNestedArray(var Data: PtrUInt);
var i: integer;
p: PDynArrayRec;
ItemData: PByte;
begin
if Data=0 then
exit;
ItemData := pointer(Data);
p := pointer(Data);
dec(p);
Data := 0;
if (p^.refCnt>=0) and DACntDecFree(p^.refCnt) then begin
for i := 1 to p^.length do
FinalizeNestedRecord(ItemData);
FreeMem(p);
end;
end;
procedure TJSONCustomParserRTTI.AllocateNestedArray(var Data: PtrUInt;
NewLength: integer);
begin
FinalizeNestedArray(Data);
if NewLength<=0 then
exit;
pointer(Data) := AllocMem(SizeOf(TDynArrayRec)+fNestedDataSize*NewLength);
PDynArrayRec(Data)^.refCnt := 1;
PDynArrayRec(Data)^.length := NewLength;
inc(Data,SizeOf(TDynArrayRec));
end;
procedure TJSONCustomParserRTTI.ReAllocateNestedArray(var Data: PtrUInt;
NewLength: integer);
var OldLength: integer;
p: PDynArrayRec;
begin
p := pointer(Data);
if p=nil then
raise ESynException.CreateUTF8('%.ReAllocateNestedArray(nil)',[self]);
dec(p);
ReAllocMem(p,SizeOf(p^)+fNestedDataSize*NewLength);
OldLength := p^.length;
if NewLength>OldLength then
FillCharFast(PByteArray(p)[SizeOf(p^)+fNestedDataSize*OldLength],
fNestedDataSize*(NewLength-OldLength),0);
p^.length := NewLength;
inc(p);
Data := PtrUInt(p);
end;
function TJSONCustomParserRTTI.ReadOneLevel(var P: PUTF8Char; var Data: PByte;
Options: TJSONCustomParserSerializationOptions{$ifndef NOVARIANTS};
CustomVariantOptions: PDocVariantOptions{$endif}): boolean;
var EndOfObject: AnsiChar;
function ProcessValue(const Prop: TJSONCustomParserRTTI; var P: PUTF8Char;
var Data: PByte): boolean;
var DynArray: PByte;
ArrayLen, ArrayCapacity, n, PropValueLen: integer;
wasString: boolean;
PropValue, ptr: PUTF8Char;
label Error;
begin
result := false;
P := GotoNextNotSpace(P);
case Prop.PropertyType of
ptRecord: begin
if not Prop.ReadOneLevel(
P,Data,Options{$ifndef NOVARIANTS},CustomVariantOptions{$endif}) then
exit;
EndOfObject := P^;
if P^ in [',','}'] then
inc(P);
result := true;
exit;
end;
ptArray:
if (PInteger(P)^=NULL_LOW) and (jcEndOfJSONValueField in JSON_CHARS[P[4]]) then begin
P := GotoNextNotSpace(P+4);
EndOfObject := P^;
if P^<>#0 then //if P^=',' then
inc(P);
Prop.FinalizeNestedArray(PPtrUInt(Data)^); // null -> void array
end else begin
if P^<>'[' then
exit; // we expect a true array here
repeat inc(P) until P^<>' ';
// try to allocate nested array at once (if not too slow)
ArrayLen := JSONArrayCount(P,P+131072); // parse up to 128 KB here
if ArrayLen<0 then // mostly JSONArrayCount()=nil due to PMax
ArrayCapacity := 512 else
ArrayCapacity := ArrayLen;
Prop.AllocateNestedArray(PPtrUInt(Data)^,ArrayCapacity);
// read array content
if ArrayLen=0 then begin
if not NextNotSpaceCharIs(P,']') then
exit;
end else begin
n := 0;
DynArray := PPointer(Data)^;
repeat
inc(n);
if (ArrayLen<0) and (n>ArrayCapacity) then begin
ArrayCapacity := NextGrow(ArrayCapacity);
Prop.ReAllocateNestedArray(PPtrUInt(Data)^,ArrayCapacity);
DynArray := PPointer(Data)^;
inc(DynArray,pred(n)*Prop.fNestedDataSize);
end;
if Prop.NestedProperty[0].PropertyName='' then begin
// array of simple type
ptr := P;
if not ProcessValue(Prop.NestedProperty[0],ptr,DynArray) or (ptr=nil) then
goto Error;
P := ptr;
end else begin
// array of record
ptr := P;
if not Prop.ReadOneLevel(ptr,DynArray,Options{$ifndef NOVARIANTS},
CustomVariantOptions{$endif}) or (ptr=nil) then
goto Error;
P := GotoNextNotSpace(ptr);
EndOfObject := P^;
if not(P^ in [',',']']) then
goto Error;
inc(P);
end;
case EndOfObject of
',': continue;
']': begin
if ArrayLen<0 then
Prop.ReAllocateNestedArray(PPtrUInt(Data)^,n) else
if n<>ArrayLen then
goto Error;
break; // we reached end of array
end;
else begin
Error: Prop.FinalizeNestedArray(PPtrUInt(Data)^);
exit;
end;
end;
until false;
end;
if P=nil then
exit;
P := GotoNextNotSpace(P);
EndOfObject := P^;
if P^<>#0 then //if P^=',' then
inc(P);
end;
ptCustom: begin
ptr := TJSONCustomParserCustom(Prop).CustomReader(P,Data^,EndOfObject
{$ifndef NOVARIANTS},CustomVariantOptions{$endif});
if ptr=nil then
exit;
P := ptr;
end;
{$ifndef NOVARIANTS}
ptVariant:
P := VariantLoadJSON(PVariant(Data)^,P,@EndOfObject,
@JSON_OPTIONS[soCustomVariantCopiedByReference in Options]);
{$endif}
ptRawByteString: begin
PropValue := GetJSONField(P,ptr,@wasString,@EndOfObject,@PropValueLen);
if PropValue=nil then // null -> Blob=''
PRawByteString(Data)^ := '' else
if not Base64MagicCheckAndDecode(PropValue,PropValueLen,PRawByteString(Data)^) then
exit;
P := ptr;
end;
ptRawJSON:
GetJSONItemAsRawJSON(P,PRawJSON(Data)^,@EndOfObject);
else begin
PropValue := GetJSONField(P,ptr,@wasString,@EndOfObject,@PropValueLen);
if (PropValue<>nil) and // PropValue=nil for null
(wasString<>(Prop.PropertyType in [ptRawUTF8,ptString,ptSynUnicode,
{$ifdef HASVARUSTRING}ptUnicodeString,{$endif}
ptDateTime,ptDateTimeMS,ptGUID,ptWideString])) then
exit;
P := ptr;
case Prop.PropertyType of
ptBoolean: PBoolean(Data)^ := GetBoolean(PropValue);
ptByte: PByte(Data)^ := GetCardinal(PropValue);
ptCardinal: PCardinal(Data)^ := GetCardinal(PropValue);
ptCurrency: PInt64(Data)^ := StrToCurr64(PropValue);
ptDouble: unaligned(PDouble(Data)^) := GetExtended(PropValue);
ptExtended: PExtended(Data)^ := GetExtended(PropValue);
ptInt64,ptID,ptTimeLog: SetInt64(PropValue,PInt64(Data)^);
ptQWord: SetQWord(PropValue,PQWord(Data)^);
ptInteger: PInteger(Data)^ := GetInteger(PropValue);
ptSingle: PSingle(Data)^ := GetExtended(PropValue);
ptRawUTF8: FastSetString(PRawUTF8(Data)^,PropValue,PropValueLen);
ptString: UTF8DecodeToString(PropValue,PropValueLen,PString(Data)^);
ptSynUnicode:UTF8ToSynUnicode(PropValue,PropValueLen,PSynUnicode(Data)^);
{$ifdef HASVARUSTRING}
ptUnicodeString:UTF8DecodeToUnicodeString(PropValue,PropValueLen,PUnicodeString(Data)^);
{$endif}
ptDateTime, ptDateTimeMS: Iso8601ToDateTimePUTF8CharVar(
PropValue,PropValueLen,PDateTime(Data)^);
ptWideString:UTF8ToWideString(PropValue,PropValueLen,PWideString(Data)^);
ptWord: PWord(Data)^ := GetCardinal(PropValue);
ptGUID: TextToGUID(PropValue,pointer(Data));
end;
end;
end;
inc(Data,Prop.fDataSize);
result := true;
end;
var i,j: integer;
PropName: shortstring;
ptr: PUTF8Char;
Values: array of PUTF8Char;
begin
result := false;
if P=nil then
exit;
P := GotoNextNotSpace(P);
if (PInteger(P)^=NULL_LOW) and (jcEndOfJSONValueField in JSON_CHARS[P[4]]) then begin
P := GotoNextNotSpace(P+4); // a record stored as null
inc(Data,fDataSize);
result := true;
exit;
end;
EndOfObject := #0;
if not (PropertyType in [ptRecord,ptArray]) then begin
ptr := P;
result := ProcessValue(Self,P,Data);
exit;
end;
if P^<>'{' then
exit; // we expect a true object here
repeat inc(P) until (P^>' ') or (P^=#0);
if P^='}' then begin
inc(Data,fDataSize);
EndOfObject := '}';
inc(P);
end else
for i := 0 to length(NestedProperty)-1 do begin
ptr := P;
GetJSONPropName(ptr,PropName);
if PropName='' then
exit; // invalid JSON content
P := ptr;
if IdemPropNameU(NestedProperty[i].PropertyName,@PropName[1],ord(PropName[0])) then begin
// O(1) optimistic search
if not ProcessValue(NestedProperty[i],P,Data) then
exit;
if EndOfObject='}' then begin // ignore missing properties
for j := i+1 to length(NestedProperty)-1 do
inc(Data,NestedProperty[j].fDataSize);
break;
end;
end else begin
SetLength(Values,length(NestedProperty)); // pessimistic check through all properties
repeat
for j := i to length(NestedProperty)-1 do
if (Values[j]=nil) and
IdemPropNameU(NestedProperty[j].PropertyName,@PropName[1],ord(PropName[0])) then begin
Values[j] := P;
PropName := '';
break;
end;
if (PropName<>'') and not(soReadIgnoreUnknownFields in Options) then
exit; // unexpected property
ptr := GotoNextJSONItem(P,1,@EndOfObject);
if ptr=nil then
exit;
P := ptr;
if EndOfObject='}' then
break;
GetJSONPropName(ptr,PropName); // next name
if PropName='' then
exit; // invalid JSON content
P := ptr;
until false;
for j := i to length(NestedProperty)-1 do
if Values[j]=nil then // ignore missing properties
inc(Data,NestedProperty[j].fDataSize) else
if not ProcessValue(NestedProperty[j],Values[j],Data) then
exit;
EndOfObject := '}'; // ProcessValue() did update EndOfObject
break;
end;
end;
if (P<>nil) and (EndOfObject=',') and (soReadIgnoreUnknownFields in Options) then begin
ptr := GotoNextJSONObjectOrArray(P,'}');
if ptr=nil then
exit;
P := ptr;
end else
if EndOfObject<>'}' then
exit;
if P<>nil then
P := GotoNextNotSpace(P);
result := true;
end;
function Plural(const itemname: shortstring; itemcount: cardinal): shortstring;
var len,L: PtrInt;
begin
len := (AppendUInt32ToBuffer(@result[1],itemcount)-PUTF8Char(@result[1]))+1;
result[len] := ' ';
L := ord(itemname[0]);
if L in [1..240] then begin // avoid buffer overflow
MoveSmall(@itemname[1],@result[len+1],L);
inc(len,L);
if itemcount>1 then begin
inc(len);
result[len] := 's';
end;
end;
result[0] := AnsiChar(len);
end;
function TJSONCustomParserRTTI.IfDefaultSkipped(var Value: PByte): boolean;
begin
case PropertyType of
ptBoolean: result := not PBoolean(Value)^;
ptByte: result := PByte(Value)^=0;
ptWord: result := PWord(Value)^=0;
ptInteger,ptCardinal,ptSingle:
result := PInteger(Value)^=0;
ptCurrency,ptDouble,ptInt64,ptQWord,ptID,ptTimeLog,ptDateTime,ptDateTimeMS:
result := PInt64(Value)^=0;
ptExtended: result := PExtended(Value)^=0;
{$ifndef NOVARIANTS}
ptVariant: result := integer(PVarData(Value)^.VType)<=varNull;
{$endif}
ptRawJSON,ptRawByteString,ptRawUTF8,ptString,ptSynUnicode,ptWideString,
{$ifdef HASVARUSTRING}ptUnicodeString,{$endif}ptArray:
result := PPointer(Value)^=nil;
ptGUID: result := IsNullGUID(PGUID(Value)^);
ptRecord: result := IsZero(Value,fDataSize);
else result := false;
end;
if result then
inc(Value,fDataSize);
end;
procedure TJSONCustomParserRTTI.WriteOneSimpleValue(aWriter: TTextWriter; var Value: PByte;
Options: TJSONCustomParserSerializationOptions);
var DynArray: PByte;
j: integer;
begin
case PropertyType of
ptBoolean: aWriter.Add(PBoolean(Value)^);
ptByte: aWriter.AddU(PByte(Value)^);
ptCardinal: aWriter.AddU(PCardinal(Value)^);
ptCurrency: aWriter.AddCurr64(PInt64(Value)^);
ptDouble: aWriter.AddDouble(unaligned(PDouble(Value)^));
ptExtended: aWriter.Add(PExtended(Value)^,EXTENDED_PRECISION);
ptInt64,ptID,ptTimeLog:
aWriter.Add(PInt64(Value)^);
ptQWord: aWriter.AddQ(PQWord(Value)^);
ptInteger: aWriter.Add(PInteger(Value)^);
ptSingle: aWriter.AddSingle(PSingle(Value)^);
ptWord: aWriter.AddU(PWord(Value)^);
{$ifndef NOVARIANTS}
ptVariant: aWriter.AddVariant(PVariant(Value)^,twJSONEscape);
{$endif}
ptRawJSON: aWriter.AddRawJSON(PRawJSON(Value)^);
ptRawByteString:
aWriter.WrBase64(PPointer(Value)^,length(PRawByteString(Value)^),{withMagic=}true);
ptRawUTF8, ptString, ptSynUnicode,{$ifdef HASVARUSTRING}ptUnicodeString,{$endif}
ptDateTime, ptDateTimeMS, ptGUID, ptWideString: begin
aWriter.Add('"');
case PropertyType of
ptRawUTF8: aWriter.AddJSONEscape(PPointer(Value)^);
ptString: aWriter.AddJSONEscapeString(PString(Value)^);
ptSynUnicode,{$ifdef HASVARUSTRING}ptUnicodeString,{$endif}
ptWideString: aWriter.AddJSONEscapeW(PPointer(Value)^);
ptDateTime: aWriter.AddDateTime(unaligned(PDateTime(Value)^),{withms=}false);
ptDateTimeMS: aWriter.AddDateTime(unaligned(PDateTime(Value)^),true);
ptGUID: aWriter.Add(PGUID(Value)^);
end;
aWriter.Add('"');
end;
ptArray: begin
aWriter.Add('[');
inc(aWriter.fHumanReadableLevel);
DynArray := PPointer(Value)^;
if DynArray<>nil then
for j := 1 to DynArrayLength(DynArray) do begin
if soWriteHumanReadable in Options then
aWriter.AddCRAndIndent;
if NestedProperty[0].PropertyName='' then // array of simple
NestedProperty[0].WriteOneSimpleValue(aWriter,DynArray,Options) else
WriteOneLevel(aWriter,DynArray,Options); // array of record
aWriter.Add(',');
{$ifdef ALIGNCUSTOMREC}
if PtrUInt(DynArray)and 7<>0 then
inc(DynArray,8-(PtrUInt(DynArray)and 7));
{$endif}
end;
aWriter.CancelLastComma;
aWriter.Add(']');
dec(aWriter.fHumanReadableLevel);
end;
ptRecord: begin
WriteOneLevel(aWriter,Value,Options);
exit;
end;
ptCustom:
TJSONCustomParserCustom(self).CustomWriter(aWriter,Value^);
end;
inc(Value,fDataSize);
end;
procedure TJSONCustomParserRTTI.WriteOneLevel(aWriter: TTextWriter; var P: PByte;
Options: TJSONCustomParserSerializationOptions);
var i: integer;
SubProp: TJSONCustomParserRTTI;
begin
if P=nil then begin
aWriter.AddShort('null');
exit;
end;
if not (PropertyType in [ptRecord,ptArray]) then begin
WriteOneSimpleValue(aWriter,P,Options);
exit;
end;
aWriter.Add('{');
Inc(aWriter.fHumanReadableLevel);
for i := 0 to length(NestedProperty)-1 do begin
SubProp := NestedProperty[i];
if soWriteIgnoreDefault in Options then
if SubProp.IfDefaultSkipped(P) then
continue;
if soWriteHumanReadable in Options then
aWriter.AddCRAndIndent;
aWriter.AddFieldName(SubProp.PropertyName);
if soWriteHumanReadable in Options then
aWriter.Add(' ');
SubProp.WriteOneSimpleValue(aWriter,P,Options);
aWriter.Add(',');
end;
aWriter.CancelLastComma;
dec(aWriter.fHumanReadableLevel);
if soWriteHumanReadable in Options then
aWriter.AddCRAndIndent;
aWriter.Add('}');
end;
{ TJSONRecordAbstract }
constructor TJSONRecordAbstract.Create;
begin
fItems := TSynObjectList.Create;
end;
function TJSONRecordAbstract.AddItem(const aPropertyName: RawUTF8;
aPropertyType: TJSONCustomParserRTTIType;
const aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI;
begin
if aPropertyType=ptCustom then begin
result := TJSONCustomParserRTTI.CreateFromTypeName(
aPropertyName,aCustomRecordTypeName);
if result=nil then
raise ESynException.CreateUTF8('Unregistered ptCustom for %.AddItem(%: %)',
[self,aPropertyName,aCustomRecordTypeName]);
end else
result := TJSONCustomParserRTTI.Create(aPropertyName,aPropertyType);
fItems.Add(result);
end;
function TJSONRecordAbstract.CustomReader(P: PUTF8Char; var aValue;
out aValid: Boolean{$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char;
var Data: PByte;
EndOfObject: AnsiChar;
begin
if Root.PropertyType=ptCustom then begin
result := TJSONCustomParserCustom(Root).CustomReader(P,aValue,EndOfObject
{$ifndef NOVARIANTS},CustomVariantOptions{$endif});
aValid := result<>nil;
if (EndOfObject<>#0) and aValid then begin
dec(result);
result^ := EndOfObject; // emulates simple read
end;
exit;
end;
Data := @aValue;
aValid := Root.ReadOneLevel(P,Data,Options{$ifndef NOVARIANTS},CustomVariantOptions{$endif});
result := P;
end;
procedure TJSONRecordAbstract.CustomWriter(const aWriter: TTextWriter; const aValue);
var P: PByte;
o: TJSONCustomParserSerializationOptions;
begin
P := @aValue;
o := Options;
if twoIgnoreDefaultInRecord in aWriter.CustomOptions then
include(o,soWriteIgnoreDefault);
Root.WriteOneLevel(aWriter,P,o);
end;
destructor TJSONRecordAbstract.Destroy;
begin
FreeAndNil(fItems);
inherited;
end;
{ TJSONRecordTextDefinition }
var
JSONCustomParserCache: TRawUTF8List;
class function TJSONRecordTextDefinition.FromCache(aTypeInfo: pointer;
const aDefinition: RawUTF8): TJSONRecordTextDefinition;
begin
if JSONCustomParserCache=nil then
GarbageCollectorFreeAndNil(JSONCustomParserCache,
TRawUTF8List.Create([fObjectsOwned,fNoDuplicate,fCaseSensitive]));
result := JSONCustomParserCache.GetObjectFrom(aDefinition);
if result<>nil then
exit;
result := TJSONRecordTextDefinition.Create(aTypeInfo,aDefinition);
JSONCustomParserCache.AddObjectUnique(aDefinition,@result);
end;
constructor TJSONRecordTextDefinition.Create(aRecordTypeInfo: pointer;
const aDefinition: RawUTF8);
var P: PUTF8Char;
recordInfoSize: integer;
begin
inherited Create;
fDefinition := aDefinition;
fRoot := TJSONCustomParserRTTI.Create('',ptRecord);
TypeInfoToName(aRecordTypeInfo,fRoot.fCustomTypeName);
fItems.Add(fRoot);
P := pointer(aDefinition);
Parse(fRoot,P,eeNothing);
fRoot.ComputeDataSizeAfterAdd;
recordInfoSize := RecordTypeInfoSize(aRecordTypeInfo);
if (recordInfoSize<>0) and (fRoot.fDataSize<>recordInfoSize) then
raise ESynException.CreateUTF8('%.Create: % text definition is not accurate,'+
' or the type has not been defined as PACKED record: RTTI size is %'+
' bytes but text definition covers % bytes',
[self,fRoot.fCustomTypeName,recordInfoSize,fRoot.fDataSize]);
end;
function DynArrayItemTypeLen(const aDynArrayTypeName: RawUTF8): PtrInt;
begin
result := length(aDynArrayTypeName);
if (result>12) and IdemPropName('DynArray',@PByteArray(aDynArrayTypeName)[result-8],8) then
dec(result,8) else
if (result>3) and (aDynArrayTypeName[result] in ['s','S']) then
dec(result) else
result := 0;
end;
function DynArrayItemTypeIsSimpleBinary(const aDynArrayTypeName: RawUTF8): boolean;
var itemLen,dataSize,fieldSize: integer;
begin
itemLen := DynArrayItemTypeLen(aDynArrayTypeName);
result := (itemLen>0) and TJSONCustomParserRTTI.TypeNameToSimpleBinary(
copy(aDynArrayTypeName,1,itemLen),dataSize,fieldSize);
end;
procedure TJSONRecordTextDefinition.Parse(Props: TJSONCustomParserRTTI;
var P: PUTF8Char; PEnd: TJSONCustomParserRTTIExpectedEnd);
function GetNextFieldType(var P: PUTF8Char;
var TypIdent: RawUTF8): TJSONCustomParserRTTIType;
begin
if GetNextFieldProp(P,TypIdent) then
result := TJSONCustomParserRTTI.TypeNameToSimpleRTTIType(
pointer(TypIdent),length(TypIdent),@TypIdent) else
raise ESynException.CreateUTF8('%.Parse: missing field type',[self]);
end;
var PropsName: TRawUTF8DynArray;
PropsMax, ndx, len, firstNdx: cardinal;
Typ, ArrayTyp: TJSONCustomParserRTTIType;
TypIdent, ArrayTypIdent: RawUTF8;
Item: TJSONCustomParserRTTI;
ExpectedEnd: TJSONCustomParserRTTIExpectedEnd;
begin
SetLength(PropsName,16);
PropsMax := 0;
while (P<>nil) and (P^<>#0) do begin
// fill Props[]
if P^ in ['''','"'] then begin // parse identifier as SQL string (e.g. "@field0")
P := UnQuoteSQLStringVar(P,PropsName[PropsMax]);
if P=nil then
break;
end else // regular object pascal identifier (i.e. 0..9,a..z,A..Z,_)
if not GetNextFieldProp(P,PropsName[PropsMax]) then
break;
case P^ of
',': begin
inc(P);
inc(PropsMax);
if PropsMax=cardinal(length(PropsName)) then
SetLength(PropsName,PropsMax+16);
continue; // several properties defined with the same type
end;
':': P := GotoNextNotSpace(P+1);
end;
// identify type
ArrayTyp := ptRecord;
if P^='{' then begin
Typ := ptRecord;
ExpectedEnd := eeCurly;
repeat inc(P) until (P^>' ') or (P^=#0);
end else
if P^='[' then begin
Typ := ptArray;
ExpectedEnd := eeSquare;
repeat inc(P) until (P^>' ') or (P^=#0);
end else begin
Typ := GetNextFieldType(P,TypIdent);
case Typ of
ptArray: begin
if IdemPChar(P,'OF') then begin
P := GotoNextNotSpace(P+2);
ArrayTyp := GetNextFieldType(P,ArrayTypIdent);
if ArrayTyp=ptArray then
P := nil;
end else
P := nil;
if P=nil then
raise ESynException.CreateUTF8('%.Parse: expected syntax is '+
'"array of record" or "array of SimpleType"',[self]);
if ArrayTyp=ptRecord then
ExpectedEnd := eeEndKeyWord else
ExpectedEnd := eeNothing;
end;
ptRecord:
ExpectedEnd := eeEndKeyWord;
ptCustom: begin
len := DynArrayItemTypeLen(TypIdent);
if len>0 then begin
ArrayTyp := TJSONCustomParserRTTI.TypeNameToSimpleRTTIType(
@PByteArray(TypIdent)[1],len-1,@ArrayTypIdent); // TByteDynArray -> byte
if ArrayTyp=ptCustom then begin // TMyTypeDynArray/TMyTypes -> TMyType
FastSetString(ArrayTypIdent,pointer(TypIdent),len);
if GlobalCustomJSONSerializerFromTextSimpleType.Find(ArrayTypIdent)>=0 then
Typ := ptArray;
end else
Typ := ptArray;
end;
ExpectedEnd := eeNothing;
end;
else ExpectedEnd := eeNothing;
end;
end;
// add elements
firstNdx := length(Props.fNestedProperty);
SetLength(Props.fNestedProperty,firstNdx+PropsMax+1);
for ndx := 0 to PropsMax do begin
Item := AddItem(PropsName[ndx],Typ,TypIdent);
Props.fNestedProperty[firstNdx+ndx] := Item;
if (Typ=ptArray) and (ArrayTyp<>ptRecord) then begin
SetLength(Item.fNestedProperty,1);
Item.fNestedProperty[0] := AddItem('',ArrayTyp,ArrayTypIdent);
end else
if Typ in [ptArray,ptRecord] then
if ndx=0 then // only parse once multiple fields nested type
Parse(Item,P,ExpectedEnd) else
Item.fNestedProperty := Props.fNestedProperty[firstNdx].fNestedProperty;
Item.ComputeDataSizeAfterAdd;
end;
// validate expected end
while P^ in [#1..' ',';'] do inc(P);
case PEnd of
eeEndKeyWord:
if IdemPChar(P,'END') then begin
inc(P,3);
while P^ in [#1..' ',';'] do inc(P);
break;
end;
eeSquare:
if P^=']' then begin
inc(P);
break;
end;
eeCurly:
if P^='}' then begin
inc(P);
break;
end;
end;
PropsMax := 0;
end;
end;
{ TJSONRecordRTTI }
constructor TJSONRecordRTTI.Create(aRecordTypeInfo: pointer;
aRoot: TJSONCustomParserRTTI);
begin
inherited Create;
fRecordTypeInfo := aRecordTypeInfo;
fRoot := aRoot;
if fRoot=nil then begin
{$ifdef ISDELPHI2010}
fRoot := TJSONCustomParserRTTI.Create('',ptRecord);
FromEnhancedRTTI(fRoot,aRecordTypeInfo);
if fRoot.fNestedDataSize<>RecordTypeInfoSize(aRecordTypeInfo) then
raise ESynException.CreateUTF8(
'%.Create: error when retrieving enhanced RTTI for %',
[self,fRoot.CustomTypeName]);
{$else}
raise ESynException.CreateUTF8('%.Create with no enhanced RTTI for %',
[self,PShortString(@PTypeInfo(aRecordTypeInfo).NameLen)^]);
{$endif}
end;
fItems.Add(fRoot);
GarbageCollector.Add(self);
end;
function TJSONRecordRTTI.AddItemFromRTTI(
const PropertyName: RawUTF8; Info: pointer; ItemSize: integer): TJSONCustomParserRTTI;
begin
result := TJSONCustomParserRTTI.CreateFromRTTI(PropertyName,Info,ItemSize);
fItems.Add(result);
end;
{$ifdef ISDELPHI2010}
procedure TJSONRecordRTTI.FromEnhancedRTTI(
Props: TJSONCustomParserRTTI; Info: pointer);
var FieldTable: PTypeInfo;
i: integer;
FieldSize: cardinal;
RecField: PEnhancedFieldInfo;
ItemFields: array of PEnhancedFieldInfo;
ItemField: PTypeInfo;
ItemFieldName: RawUTF8;
ItemFieldSize: cardinal;
Item, ItemArray: TJSONCustomParserRTTI;
begin // only tkRecord is needed here
FieldTable := GetTypeInfo(Info,tkRecord);
if FieldTable=nil then
raise ESynException.CreateUTF8('%.FromEnhancedRTTI(%=record?)',[self,Info]);
FieldSize := FieldTable^.recSize;
inc(PByte(FieldTable),FieldTable^.ManagedCount*SizeOf(TFieldInfo)-SizeOf(TFieldInfo));
inc(PByte(FieldTable),FieldTable^.NumOps*SizeOf(pointer)); // jump RecOps[]
if FieldTable^.AllCount=0 then
exit; // not enough RTTI -> will raise an error in Create()
TypeInfoToName(Info,Props.fCustomTypeName);
RecField := @FieldTable^.AllFields[0];
SetLength(ItemFields,FieldTable^.AllCount);
for i := 0 to FieldTable^.AllCount-1 do begin
ItemFields[i] := RecField;
inc(PByte(RecField),RecField^.NameLen); // Delphi: no AlignPtr() needed
inc(RecField);
inc(PByte(RecField),PWord(RecField)^);
end;
SetLength(Props.fNestedProperty,FieldTable^.AllCount);
for i := 0 to FieldTable^.AllCount-1 do begin
if i=FieldTable^.AllCount-1 then
ItemFieldSize := FieldSize-ItemFields[i].Offset else
ItemFieldSize := ItemFields[i+1].Offset-ItemFields[i].Offset;
ItemField := Deref(ItemFields[i]^.TypeInfo);
FastSetString(ItemFieldName,PAnsiChar(@ItemFields[i]^.NameLen)+1,ItemFields[i]^.NameLen);
Item := AddItemFromRTTI(ItemFieldName,ItemField,ItemFieldSize);
Props.fNestedProperty[i] := Item;
case Item.PropertyType of
ptArray: begin
inc(PByte(ItemField),ItemField^.NameLen);
ItemArray := AddItemFromRTTI('',Deref(ItemField^.elType2),
ItemField^.elSize {$ifdef FPC}and $7FFFFFFF{$endif});
if (ItemArray.PropertyType=ptCustom) and
(ItemArray.ClassType=TJSONCustomParserRTTI) then
FromEnhancedRTTI(Item,Deref(ItemField^.elType2)) else begin
SetLength(Item.fNestedProperty,1);
Item.fNestedProperty[0] := ItemArray;
Item.ComputeNestedDataSize;
end;
end;
ptCustom:
if (ItemField<>nil) and (Item.ClassType=TJSONCustomParserRTTI) then
FromEnhancedRTTI(Item,ItemField);
end;
end;
Props.ComputeNestedDataSize;
end;
{$endif ISDELPHI2010}
{ ************ variant-based process, including JSON/BSON document content }
{$ifndef LVCL}
procedure RawByteStringToVariant(Data: PByte; DataLen: Integer; var Value: variant);
begin
ClearVariantForString(Value);
if (Data=nil) or (DataLen<=0) then
TVarData(Value).VType := varNull else
SetString(RawByteString(TVarData(Value).VAny),PAnsiChar(Data),DataLen);
end;
procedure RawByteStringToVariant(const Data: RawByteString; var Value: variant);
begin
ClearVariantForString(Value);
if Data='' then
TVarData(Value).VType := varNull else
RawByteString(TVarData(Value).VAny) := Data;
end;
procedure VariantToRawByteString(const Value: variant; var Dest: RawByteString);
begin
case integer(TVarData(Value).VType) of
varEmpty, varNull:
Dest := '';
varString:
Dest := RawByteString(TVarData(Value).VAny);
else // not from RawByteStringToVariant() -> conversion to string
Dest := {$ifdef UNICODE}RawByteString{$else}string{$endif}(Value);
end;
end;
procedure SetVariantNull(var Value: variant);
begin // slightly faster than Value := Null
VarClear(Value);
TVarData(Value).VType := varNull;
end;
{$endif LVCL}
function VarDataIsEmptyOrNull(VarData: pointer): Boolean;
var vt: cardinal;
begin
repeat
vt := PVarData(VarData)^.VType;
if vt<>varVariant or varByRef then
break;
VarData := PVarData(VarData)^.VPointer;
if VarData=nil then begin
result := true;
exit;
end;
until false;
result := (vt<=varNull) or (vt=varNull or varByRef);
end;
function VarIsEmptyOrNull(const V: Variant): Boolean;
begin
result := VarDataIsEmptyOrNull(@V);
end;
function VarIs(const V: Variant; const VTypes: TVarDataTypes): Boolean;
var VD: PVarData;
vt: cardinal;
begin
VD := @V;
repeat
vt := VD^.VType;
if vt<>varVariant or varByRef then
break;
VD := VD^.VPointer;
if VD=nil then begin
result := false;
exit;
end;
until false;
result := vt in VTypes;
end;
function VarIsVoid(const V: Variant): boolean;
var vt: cardinal;
begin
vt := TVarData(V).VType;
with TVarData(V) do
case vt of
varEmpty,varNull:
result := true;
varBoolean:
result := not VBoolean;
varString,varOleStr{$ifdef HASVARUSTRING},varUString{$endif}:
result := VAny=nil;
varDate:
result := VInt64=0;
else
if vt=varVariant or varByRef then
result := VarIsVoid(PVariant(VPointer)^) else
if (vt=varByRef or varString) or (vt=varByRef or varOleStr)
{$ifdef HASVARUSTRING} or (vt=varByRef or varUString) {$endif} then
result := PPointer(VAny)^=nil else
{$ifndef NOVARIANTS}
if vt=cardinal(DocVariantVType) then
result := TDocVariantData(V).Count=0 else
{$endif}
result := false;
end;
end;
function VarStringOrNull(const v: RawUTF8): variant;
begin
if v='' then
SetVariantNull(result) else
{$ifdef NOVARIANTS} result := v {$else} RawUTF8ToVariant(v,result) {$endif};
end;
{$ifndef NOVARIANTS}
/// internal method used by VariantLoadJSON(), GetVariantFromJSON() and
// TDocVariantData.InitJSONInPlace()
procedure GetJSONToAnyVariant(var Value: variant; var JSON: PUTF8Char;
EndOfObject: PUTF8Char; Options: PDocVariantOptions; AllowDouble: boolean); forward;
procedure SetVariantByRef(const Source: Variant; var Dest: Variant);
var vt: cardinal;
begin
VarClear(Dest);
vt := TVarData(Source).VType;
if ((vt and varByRef)<>0) or (vt in [varEmpty..varDate,varBoolean,varShortInt..varWord64]) then
TVarData(Dest) := TVarData(Source) else
if not SetVariantUnRefSimpleValue(Source,TVarData(Dest)) then begin
TVarData(Dest).VType := varVariant or varByRef;
TVarData(Dest).VPointer := @Source;
end;
end;
procedure SetVariantByValue(const Source: Variant; var Dest: Variant);
var s: PVarData;
d: TVarData absolute Dest;
vt: cardinal;
begin
s := @Source;
VarClear(Dest);
vt := s^.VType;
if vt=varVariant or varByRef then begin
s := s^.VPointer;
vt := s^.VType;
end;
case vt of
varEmpty..varDate,varBoolean,varShortInt..varWord64: begin
d.VType := vt;
d.VInt64 := s^.VInt64;
end;
varString: begin
d.VType := varString;
d.VAny := nil;
RawByteString(d.VAny) := RawByteString(s^.VAny);
end;
varByRef or varString: begin
d.VType := varString;
d.VAny := nil;
RawByteString(d.VAny) := PRawByteString(s^.VAny)^;
end;
{$ifdef HASVARUSTRING} varUString, varByRef or varUString, {$endif}
varOleStr, varByRef or varOleStr: begin
d.VType := varString;
d.VAny := nil;
VariantToUTF8(PVariant(s)^,RawUTF8(d.VAny)); // store a RawUTF8 instance
end;
else
if not SetVariantUnRefSimpleValue(PVariant(s)^,d) then
if vt=cardinal(DocVariantVType) then
DocVariantType.CopyByValue(d,s^) else
Dest := PVariant(s)^;
end;
end;
procedure ZeroFill(Value: PVarData);
begin // slightly faster than FillChar(Value,SizeOf(Value),0);
PInt64Array(Value)^[0] := 0;
PInt64Array(Value)^[1] := 0;
{$ifdef CPU64}
//assert(SizeOf(TVarData)=24);
PInt64Array(Value)^[2] := 0;
{$endif}
end;
procedure FillZero(var value: variant);
begin
with TVarData(Value) do
if cardinal(VType)=varString then
FillZero(RawByteString(VString));
VarClear(Value);
end;
procedure RawUTF8ToVariant(Txt: PUTF8Char; TxtLen: integer; var Value: variant);
begin
ClearVariantForString(Value);
FastSetString(RawUTF8(TVarData(Value).VString), Txt, TxtLen);
end;
procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: variant);
begin
ClearVariantForString(Value);
if Txt='' then
exit;
RawByteString(TVarData(Value).VString) := Txt;
{$ifdef HASCODEPAGE} // force explicit UTF-8
SetCodePage(RawByteString(TVarData(Value).VAny),CP_UTF8,false);
{$endif HASCODEPAGE}
end;
procedure FormatUTF8ToVariant(const Fmt: RawUTF8; const Args: array of const;
var Value: variant);
begin
RawUTF8ToVariant(FormatUTF8(Fmt,Args),Value);
end;
function RawUTF8ToVariant(const Txt: RawUTF8): variant;
begin
RawUTF8ToVariant(Txt,result);
end;
procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: TVarData;
ExpectedValueType: cardinal);
begin
if ExpectedValueType=varString then begin
RawUTF8ToVariant(Txt,variant(Value));
exit;
end;
VarClear(variant(Value));
Value.VType := ExpectedValueType;
Value.VAny := nil; // avoid GPF below
if Txt<>'' then
case ExpectedValueType of
varOleStr:
UTF8ToWideString(Txt,WideString(Value.VAny));
{$ifdef HASVARUSTRING}
varUString:
UTF8DecodeToUnicodeString(pointer(Txt),length(Txt),UnicodeString(Value.VAny));
{$endif}
else raise ESynException.CreateUTF8('RawUTF8ToVariant(ExpectedValueType=%)',
[ExpectedValueType]);
end;
end;
function VariantSave(const Value: variant; Dest: PAnsiChar): PAnsiChar;
procedure ComplexType;
begin
try
Dest := pointer(ToVarString(VariantSaveJSON(Value),PByte(Dest)));
except
on Exception do
Dest := nil; // notify invalid/unhandled variant content
end;
end;
var LenBytes: integer;
tmp: TVarData;
begin
with TVarData(Value) do
if VType and varByRef<>0 then
if VType=varVariant or varByRef then begin
result := VariantSave(PVariant(VPointer)^,Dest);
exit;
end else
if SetVariantUnRefSimpleValue(Value,tmp) then begin
result := VariantSave(variant(tmp),Dest-SizeOf(VType));
exit;
end;
with TVarData(Value) do begin
PWord(Dest)^ := VType;
inc(Dest,SizeOf(VType));
case VType of
varNull, varEmpty: ;
varShortInt, varByte: begin
Dest^ := AnsiChar(VByte);
inc(Dest);
end;
varSmallint, varWord, varBoolean: begin
PWord(Dest)^ := VWord;
inc(Dest,SizeOf(VWord));
end;
varSingle, varLongWord, varInteger: begin
PInteger(Dest)^ := VInteger;
inc(Dest,SizeOf(VInteger));
end;
varInt64, varWord64, varDouble, varDate, varCurrency:begin
PInt64(Dest)^ := VInt64;
inc(Dest,SizeOf(VInt64));
end;
varString, varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: begin
if PtrUInt(VAny)=0 then
LenBytes := 0 else begin
LenBytes := PStrLen(PtrUInt(VAny)-_STRLEN)^;
{$ifdef HASVARUSTRING}
if VType=varUString then
LenBytes := LenBytes*2; // stored length is in bytes, not (wide)chars
{$endif}
end;
Dest := pointer(ToVarUInt32(LenBytes,pointer(Dest)));
if LenBytes>0 then begin // direct raw copy
MoveFast(PPtrUInt(VAny)^,Dest^,LenBytes);
inc(Dest,LenBytes);
end;
end;
else ComplexType; // complex types are stored as JSON
end;
end;
result := Dest;
end;
function VariantSaveLength(const Value: variant): integer;
var tmp: TVarData;
v: TVarData absolute Value;
begin // match VariantSave() storage
if v.VType and varByRef<>0 then
if v.VType=varVariant or varByRef then begin
result := VariantSaveLength(PVariant(v.VPointer)^);
exit;
end else
if SetVariantUnRefSimpleValue(Value,tmp) then begin
result := VariantSaveLength(variant(tmp));
exit;
end;
case v.VType of
varEmpty, varNull:
result := SizeOf(tmp.VType);
varShortInt, varByte:
result := SizeOf(tmp.VByte)+SizeOf(tmp.VType);
varSmallint, varWord, varBoolean:
result := SizeOf(tmp.VSmallint)+SizeOf(tmp.VType);
varSingle, varLongWord, varInteger:
result := SizeOf(tmp.VInteger)+SizeOf(tmp.VType);
varInt64, varWord64, varDouble, varDate, varCurrency:
result := SizeOf(tmp.VInt64)+SizeOf(tmp.VType);
varString, varOleStr:
if PtrUInt(v.VAny)=0 then
result := 1+SizeOf(tmp.VType) else
result := ToVarUInt32LengthWithData(
PStrLen(PtrUInt(v.VAny)-_STRLEN)^)+SizeOf(tmp.VType);
{$ifdef HASVARUSTRING}
varUString:
if PtrUInt(v.VAny)=0 then // stored length is in bytes, not (wide)chars
result := 1+SizeOf(tmp.VType) else
result := ToVarUInt32LengthWithData(
PStrLen(PtrUInt(v.VAny)-_STRLEN)^*2)+SizeOf(tmp.VType);
{$endif}
else
try // complex types will be stored as JSON
result := ToVarUInt32LengthWithData(VariantSaveJSONLength(Value))+SizeOf(tmp.VType);
except
on Exception do
result := 0; // notify invalid/unhandled variant content
end;
end;
end;
function VariantSave(const Value: variant): RawByteString;
var P: PAnsiChar;
begin
SetString(result,nil,VariantSaveLength(Value));
P := VariantSave(Value,pointer(result));
if P-pointer(result)<>length(result) then
raise ESynException.Create('VariantSave length');
end;
function VariantLoad(const Bin: RawByteString;
CustomVariantOptions: PDocVariantOptions): variant;
begin
if VariantLoad(result,Pointer(Bin),CustomVariantOptions,
PAnsiChar(pointer(Bin))+length(Bin))=nil then
VarClear(result);
end;
function VariantLoad(var Value: variant; Source: PAnsiChar;
CustomVariantOptions: PDocVariantOptions; SourceMax: PAnsiChar): PAnsiChar;
var JSON: PUTF8Char;
n: cardinal;
tmp: TSynTempBuffer; // GetJSON*() does in-place unescape -> private copy
begin
result := nil; // error
VarClear(Value);
if (SourceMax<>nil) and (Source+2>SourceMax) then exit;
TVarData(Value).VType := PWord(Source)^;
inc(Source,SizeOf(TVarData(Value).VType));
case TVarData(Value).VType of
varNull, varEmpty: ;
varShortInt, varByte: begin
if (SourceMax<>nil) and (Source>=SourceMax) then exit;
TVarData(Value).VByte := byte(Source^);
inc(Source);
end;
varSmallint, varWord, varBoolean: begin
if (SourceMax<>nil) and (Source+2>SourceMax) then exit;
TVarData(Value).VWord := PWord(Source)^;
inc(Source,SizeOf(Word));
end;
varSingle, varLongWord, varInteger: begin
if (SourceMax<>nil) and (Source+4>SourceMax) then exit;
TVarData(Value).VInteger := PInteger(Source)^;
inc(Source,SizeOf(Integer));
end;
varInt64, varWord64, varDouble, varDate, varCurrency: begin
if (SourceMax<>nil) and (Source+8>SourceMax) then exit;
TVarData(Value).VInt64 := PInt64(Source)^;
inc(Source,SizeOf(Int64));
end;
varString, varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: begin
TVarData(Value).VAny := nil; // avoid GPF below when assigning a string variable to VAny
if not FromVarUInt32(PByte(Source),PByte(SourceMax),n) or
((SourceMax<>nil) and (Source+n>SourceMax)) then
exit;
case TVarData(Value).VType of
varString:
FastSetString(RawUTF8(TVarData(Value).VString),Source,n); // explicit RawUTF8
varOleStr:
SetString(WideString(TVarData(Value).VAny),PWideChar(Source),n shr 1);
{$ifdef HASVARUSTRING}
varUString:
SetString(UnicodeString(TVarData(Value).VAny),PWideChar(Source),n shr 1);
{$endif}
end;
inc(Source,n);
end;
else
if CustomVariantOptions<>nil then begin
try // expected format for complex type is JSON (VType may differ)
if FromVarString(PByte(Source),PByte(SourceMax),tmp) then
try
JSON := tmp.buf;
TVarData(Value).VType := varEmpty; // avoid GPF below
GetJSONToAnyVariant(Value,JSON,nil,CustomVariantOptions,false);
finally
tmp.Done;
end else
exit;
except
on Exception do
exit; // notify invalid/unhandled variant content
end;
end else
exit;
end;
result := Source;
end;
procedure FromVarVariant(var Source: PByte; var Value: variant;
CustomVariantOptions: PDocVariantOptions);
begin
Source := PByte(VariantLoad(Value,PAnsiChar(Source),CustomVariantOptions));
end;
function VariantLoadJSON(var Value: variant; JSON: PUTF8Char; EndOfObject: PUTF8Char;
TryCustomVariants: PDocVariantOptions; AllowDouble: boolean): PUTF8Char;
var wasString: boolean;
Val: PUTF8Char;
begin
result := JSON;
if JSON=nil then
exit;
if TryCustomVariants<>nil then begin
if dvoJSONObjectParseWithinString in TryCustomVariants^ then begin
JSON := GotoNextNotSpace(JSON);
if JSON^='"' then begin
Val := GetJSONField(result,result,@wasString,EndOfObject);
GetJSONToAnyVariant(Value,Val,EndOfObject,TryCustomVariants,AllowDouble);
end else
GetJSONToAnyVariant(Value,result,EndOfObject,TryCustomVariants,AllowDouble);
end else
GetJSONToAnyVariant(Value,result,EndOfObject,TryCustomVariants,AllowDouble);
end else begin
Val := GetJSONField(result,result,@wasString,EndOfObject);
GetVariantFromJSON(Val,wasString,Value,nil,AllowDouble);
end;
if result=nil then
result := @NULCHAR; // reached end, but not invalid input
end;
procedure VariantLoadJSON(var Value: Variant; const JSON: RawUTF8;
TryCustomVariants: PDocVariantOptions; AllowDouble: boolean);
var tmp: TSynTempBuffer;
begin
tmp.Init(JSON); // temp copy before in-place decoding
try
VariantLoadJSON(Value,tmp.buf,nil,TryCustomVariants,AllowDouble);
finally
tmp.Done;
end;
end;
function VariantLoadJSON(const JSON: RawUTF8; TryCustomVariants: PDocVariantOptions;
AllowDouble: boolean): variant;
var tmp: TSynTempBuffer;
begin
tmp.Init(JSON);
try
VariantLoadJSON(result,tmp.buf,nil,TryCustomVariants,AllowDouble);
finally
tmp.Done;
end;
end;
function VariantSaveJSON(const Value: variant; Escape: TTextWriterKind): RawUTF8;
begin
VariantSaveJSON(Value,Escape,result);
end;
procedure VariantSaveJSON(const Value: variant; Escape: TTextWriterKind;
var result: RawUTF8);
var temp: TTextWriterStackBuffer;
begin // not very optimized, but fast enough in practice, and creates valid JSON
with DefaultTextWriterSerializer.CreateOwnedStream(temp) do
try
AddVariant(Value,Escape); // may encounter TObjectVariant -> WriteObject
SetText(result);
finally
Free;
end;
end;
function VariantSaveJSONLength(const Value: variant; Escape: TTextWriterKind): integer;
var Fake: TFakeWriterStream;
temp: TTextWriterStackBuffer;
begin // will avoid most memory allocations
Fake := TFakeWriterStream.Create;
try
with DefaultTextWriterSerializer.Create(Fake,@temp,SizeOf(temp)) do
try
AddVariant(Value,Escape);
FlushFinal;
result := fTotalFileSize;
finally
Free;
end;
finally
Fake.Free;
end;
end;
procedure VariantToVarRec(const V: variant; var result: TVarRec);
begin
result.VType := vtVariant;
if TVarData(V).VType=varByRef or varVariant then
result.VVariant := TVarData(V).VPointer else
result.VVariant := @V;
end;
function VarRecToVariant(const V: TVarRec): variant;
begin
VarRecToVariant(V,result);
end;
procedure VarRecToVariant(const V: TVarRec; var result: variant);
begin
VarClear(result);
with TVarData(result) do
case V.VType of
vtPointer:
VType := varNull;
vtBoolean: begin
VType := varBoolean;
VBoolean := V.VBoolean;
end;
vtInteger: begin
VType := varInteger;
VInteger := V.VInteger;
end;
vtInt64: begin
VType := varInt64;
VInt64 := V.VInt64^;
end;
{$ifdef FPC}
vtQWord: begin
VType := varQWord;
VQWord := V.VQWord^;
end;
{$endif}
vtCurrency: begin
VType := varCurrency;
VCurrency := V.VCurrency^;
end;
vtExtended: begin
VType := varDouble;
VDouble := V.VExtended^;
end;
vtVariant:
result := V.VVariant^;
vtAnsiString: begin
VType := varString;
VAny := nil;
RawByteString(VAny) := RawByteString(V.VAnsiString);
end;
vtString, {$ifdef HASVARUSTRING}vtUnicodeString,{$endif}
vtPChar, vtChar, vtWideChar, vtWideString, vtClass: begin
VType := varString;
VString := nil; // avoid GPF on next line
VarRecToUTF8(V,RawUTF8(VString)); // convert to a new RawUTF8 instance
end;
vtObject: // class instance will be serialized as a TDocVariant
ObjectToVariant(V.VObject,result,[woDontStoreDefault]);
else raise ESynException.CreateUTF8('Unhandled TVarRec.VType=%',[V.VType]);
end;
end;
{ TSynInvokeableVariantType }
function TSynInvokeableVariantType.IterateCount(const V: TVarData): integer;
begin
result := -1; // this is not an array
end;
procedure TSynInvokeableVariantType.Iterate(var Dest: TVarData; const V: TVarData;
Index: integer);
begin // do nothing
end;
{$ifndef FPC}
{$ifndef DELPHI6OROLDER}
function TSynInvokeableVariantType.FixupIdent(const AText: string): string;
begin
result := AText; // NO uppercased identifier for our custom types!
end;
{$endif DELPHI6OROLDER}
{$endif FPC}
function TSynInvokeableVariantType.IntGet(var Dest: TVarData; const Instance: TVarData;
Name: PAnsiChar; NameLen: PtrInt): boolean;
begin
raise ESynException.CreateUTF8('Unexpected %.IntGet(%): this kind of '+
'custom variant does not support sub-fields',[self,Name]);
end;
function TSynInvokeableVariantType.IntSet(const Instance, Value: TVarData;
Name: PAnsiChar; NameLen: PtrInt): boolean;
begin
raise ESynException.CreateUTF8('Unexpected %.IntSet(%): this kind of '+
'custom variant is read-only',[self,Name]);
end;
function TSynInvokeableVariantType.GetProperty(var Dest: TVarData;
const V: TVarData; const Name: String): Boolean;
{$ifdef UNICODE} var Buf: array[byte] of AnsiChar; {$endif}
begin
IntGet(Dest,V,{$ifdef UNICODE}Buf,RawUnicodeToUtf8(Buf,SizeOf(Buf),
pointer(Name),length(Name),[]){$else}pointer(Name),length(Name){$endif});
result := true; // IntGet=false+Dest=null e.g. if dvoReturnNullForUnknownProperty
end;
{$ifdef FPC_VARIANTSETVAR} // see http://mantis.freepascal.org/view.php?id=26773
function TSynInvokeableVariantType.SetProperty(var V: TVarData;
const Name: string; const Value: TVarData): Boolean;
{$else}
function TSynInvokeableVariantType.SetProperty(const V: TVarData;
const Name: string; const Value: TVarData): Boolean;
{$endif}
var ValueSet: TVarData;
PropName: PAnsiChar;
Unicode: pointer;
PropNameLen, UnicodeLen: PtrInt;
vt: cardinal;
{$ifdef UNICODE}
Buf: array[byte] of AnsiChar; // to avoid heap allocation
{$endif}
begin
{$ifdef UNICODE}
PropNameLen := RawUnicodeToUtf8(Buf,SizeOf(Buf),pointer(Name),length(Name),[]);
PropName := @Buf[0];
{$else}
PropName := pointer(Name);
PropNameLen := length(Name);
{$endif}
vt := Value.VType;
if vt=varByRef or varOleStr then begin
Unicode := PPointer(Value.VAny)^;
UnicodeLen := length(WideString(Unicode));
end else
if vt=varOleStr then begin
Unicode := Value.VAny;
UnicodeLen := length(WideString(Unicode));
end else
{$ifdef HASVARUSTRING}
if vt=varByRef or varUString then begin
Unicode := PPointer(Value.VAny)^;
UnicodeLen := length(UnicodeString(Unicode));
end else
if vt=varUString then begin
Unicode := Value.VAny;
UnicodeLen := length(UnicodeString(Unicode));
end else
{$endif}
if SetVariantUnRefSimpleValue(variant(Value),ValueSet) then begin
result := IntSet(V,ValueSet,PropName,PropNameLen);
exit;
end else begin
result := IntSet(V,Value,PropName,PropNameLen);
exit;
end;
try // unpatched RTL does not like Unicode values :( -> use a temp RawUTF8
ValueSet.VType := varString;
ValueSet.VString := nil; // to avoid GPF in next line
RawUnicodeToUtf8(Unicode,UnicodeLen,RawUTF8(ValueSet.VString));
result := IntSet(V,ValueSet,PropName,PropNameLen);
finally
RawUTF8(ValueSet.VString) := ''; // avoid memory leak
end;
end;
procedure TSynInvokeableVariantType.Clear(var V: TVarData);
begin
ZeroFill(@V); // will set V.VType := varEmpty
end;
procedure TSynInvokeableVariantType.Copy(var Dest: TVarData;
const Source: TVarData; const Indirect: Boolean);
begin
if Indirect then
SimplisticCopy(Dest,Source,true) else begin
VarClear(variant(Dest)); // Dest may be a complex type
Dest := Source;
end;
end;
procedure TSynInvokeableVariantType.CopyByValue(var Dest: TVarData; const Source: TVarData);
begin
Copy(Dest,Source,false);
end;
function TSynInvokeableVariantType.TryJSONToVariant(var JSON: PUTF8Char;
var Value: variant; EndOfObject: PUTF8Char): boolean;
begin
result := false;
end;
procedure TSynInvokeableVariantType.ToJSON(W: TTextWriter; const Value: variant;
Escape: TTextWriterKind);
begin
raise ESynException.CreateUTF8('%.ToJSON: unimplemented variant type',[self]);
end;
function TSynInvokeableVariantType.IsOfType(const V: variant): boolean;
var vt: cardinal;
vd: PVarData;
begin
if self<>nil then begin
vd := @V;
repeat
vt := vd^.VType;
if vt<>varByRef or varVariant then
break;
vd := vd^.VPointer;
until false;
result := vt=VarType;
end else
result := false;
end;
var // owned by Variants.pas as TInvokeableVariantType/TCustomVariantType
SynVariantTypes: array of TSynInvokeableVariantType;
function FindSynVariantTypeFromVType(aVarType: cardinal): TSynInvokeableVariantType;
{$ifdef HASINLINE}inline;{$endif}
var i: integer;
t: ^TSynInvokeableVariantType;
begin
t := pointer(SynVariantTypes);
for i := 1 to length(TObjectDynArray(t)) do begin
result := t^;
if result.VarType=aVarType then
exit;
inc(t);
end;
result := nil;
end;
function TSynInvokeableVariantType.FindSynVariantType(aVarType: Word;
out CustomType: TSynInvokeableVariantType): boolean;
begin
if aVarType=VarType then
CustomType := self else
CustomType := FindSynVariantTypeFromVType(VarType);
result := CustomType<>nil;
end;
procedure TSynInvokeableVariantType.Lookup(var Dest: TVarData; const Instance: TVarData;
FullName: PUTF8Char);
var handler: TSynInvokeableVariantType;
v, tmp: TVarData; // PVarData wouldn't store e.g. RowID/count
vt: cardinal;
itemName: ShortString;
begin
PInteger(@Dest)^ := varEmpty; // left to Unassigned if not found
v := Instance;
repeat
vt := v.VType;
if vt<>varByRef or varVariant then
break;
v := PVarData(v.VPointer)^;
until false;
repeat
if vt<=varString then
exit; // we need a complex type to lookup
GetNextItemShortString(FullName,itemName,'.');
if itemName[0] in [#0,#255] then
exit;
itemName[ord(itemName[0])+1] := #0; // ensure is ASCIIZ
if vt=VarType then
handler := self else begin
handler := FindSynVariantTypeFromVType(vt);
if handler=nil then
exit;
end;
tmp := v; // v will be modified in-place
PInteger(@v)^ := varEmpty; // IntGet() would clear it otherwise!
if not handler.IntGet(v,tmp,@itemName[1],ord(itemName[0])) then
exit; // property not found
repeat
vt := v.VType;
if vt<>varByRef or varVariant then
break;
v := PVarData(v.VPointer)^;
until false;
if (vt=cardinal(DocVariantVType)) and (TDocVariantData(v).VCount=0) then
v.VType := varNull; // recognize void TDocVariant as null
until FullName=nil;
Dest := v;
end;
procedure GetJSONToAnyVariant(var Value: variant; var JSON: PUTF8Char;
EndOfObject: PUTF8Char; Options: PDocVariantOptions; AllowDouble: boolean);
// internal method used by VariantLoadJSON(), GetVariantFromJSON() and
// TDocVariantData.InitJSON()
procedure ProcessField;
var val: PUTF8Char;
wasString: boolean;
begin
val := GetJSONField(JSON,JSON,@wasString,EndOfObject);
GetVariantFromJSON(val,wasString,Value,nil,AllowDouble);
if JSON=nil then
JSON := @NULCHAR;
end;
var i: integer;
t: ^TSynInvokeableVariantType;
ToBeParsed: PUTF8Char;
wasParsedWithinString: boolean;
wasString: boolean;
begin
VarClear(Value);
if (Options<>nil) and (dvoAllowDoubleValue in Options^) then
AllowDouble := true; // for ProcessField() above
if EndOfObject<>nil then
EndOfObject^ := ' ';
while (JSON^<=' ') and (JSON^<>#0) do inc(JSON);
if (Options=nil) or (JSON^ in ['-','0'..'9']) or (PInteger(JSON)^=NULL_LOW) or
(PInteger(JSON)^=TRUE_LOW) or (PInteger(JSON)^=FALSE_LOW) then begin
ProcessField; // obvious simple type
exit;
end;
wasParsedWithinString := false;
if JSON^='"' then
if dvoJSONObjectParseWithinString in Options^ then begin
ToBeParsed := GetJSONField(JSON,JSON,@wasString,EndOfObject);
EndOfObject := nil; // already set just above
wasParsedWithinString := true;
end else begin
ProcessField;
exit;
end else
ToBeParsed := JSON;
t := pointer(SynVariantTypes);
if (t<>nil) and not(dvoJSONParseDoNotTryCustomVariants in Options^) then
for i := {$ifdef FPC}0{$else}1{$endif} to PDALen(PtrUInt(t)-_DALEN)^ do
if t^.TryJSONToVariant(ToBeParsed,Value,EndOfObject) then begin
if not wasParsedWithinString then
JSON := ToBeParsed;
exit;
end else
inc(t);
if ToBeParsed^ in ['[','{'] then begin
// default JSON parsing and conversion to TDocVariant instance
ToBeParsed := TDocVariantData(Value).InitJSONInPlace(ToBeParsed,Options^,EndOfObject);
if ToBeParsed=nil then begin
TDocVariantData(Value).Clear;
exit; // eror parsing
end;
if not wasParsedWithinString then
JSON := ToBeParsed;
end else
// back to simple variant types
if wasParsedWithinString then
GetVariantFromJSON(ToBeParsed,wasString,Value,nil,AllowDouble) else
ProcessField;
end;
function TextToVariantNumberTypeNoDouble(json: PUTF8Char): cardinal;
var start: PUTF8Char;
c: AnsiChar;
begin
result := varString;
c := json[0];
if (jcDigitFirstChar in JSON_CHARS[c]) and
(((c>='1') and (c<='9')) or // is first char numeric?
((c='0') and ((json[1]='.') or (json[1]=#0))) or // '012' excluded by JSON
((c='-') and (json[1]>='0') and (json[1]<='9'))) then begin
start := json;
repeat inc(json) until (json^<'0') or (json^>'9'); // check digits
case json^ of
'.':
if (json[1]>='0') and (json[1]<='9') and (json[2] in [#0,'0'..'9']) then
if (json[2]=#0) or (json[3]=#0) or
((json[3]>='0') and (json[3]<='9') and (json[4]=#0) or
((json[4]>='0') and (json[4]<='9') and (json[5]=#0))) then
result := varCurrency; // currency ###.1234 number
#0:
if json-start<=19 then // signed Int64 precision
result := varInt64;
end;
end;
end;
function TextToVariantNumberType(json: PUTF8Char): cardinal;
var start: PUTF8Char;
exp: PtrInt;
c: AnsiChar;
label exponent;
begin
result := varString;
c := json[0];
if (jcDigitFirstChar in JSON_CHARS[c]) and
(((c>='1') and (c<='9')) or // is first char numeric?
((c='0') and ((json[1]='.') or (json[1]=#0))) or // '012' excluded by JSON
((c='-') and (json[1]>='0') and (json[1]<='9'))) then begin
start := json;
repeat inc(json) until (json^<'0') or (json^>'9'); // check digits
case json^ of
#0:
if json-start<=19 then // signed Int64 precision
result := varInt64 else
result := varDouble; // we may lost precision, but still a number
'.':
if (json[1]>='0') and (json[1]<='9') and (json[2] in [#0,'e','E','0'..'9']) then
if (json[2]=#0) or (json[3]=#0) or
((json[3]>='0') and (json[3]<='9') and (json[4]=#0) or
((json[4]>='0') and (json[4]<='9') and (json[5]=#0))) then
result := varCurrency // currency ###.1234 number
else begin
repeat // more than 4 decimals
inc(json)
until (json^<'0') or (json^>'9');
case json^ of
#0:
result := varDouble;
'e','E': begin
exponent: inc(json); // inlined custom GetInteger()
start := json;
c := json^;
if (c='-') or (c='+') then begin
inc(json);
c := json^;
end;
inc(json);
dec(c,48);
if c>#9 then
exit;
exp := ord(c);
c := json^;
dec(c,48);
if c<=#9 then begin
inc(json);
exp := exp*10+ord(c);
c := json^;
dec(c,48);
if c<=#9 then begin
inc(json);
exp := exp*10+ord(c);
end;
end;
if json^<>#0 then
exit;
if start^='-' then
exp := -exp;
if (exp>-324) and (exp<308) then
result := varDouble; // 5.0 x 10^-324 .. 1.7 x 10^308
end;
end;
end;
'e','E':
goto exponent;
end;
end;
end;
function GetNumericVariantFromJSON(JSON: PUTF8Char; var Value: TVarData;
AllowVarDouble: boolean): boolean;
var err: integer;
typ: cardinal;
label dbl;
begin
if JSON<>nil then begin
if AllowVarDouble then
typ := TextToVariantNumberType(JSON) else
typ := TextToVariantNumberTypeNoDouble(JSON);
with Value do
case typ of
varInt64: begin
VInt64 := GetInt64(JSON,err);
if err<>0 then // overflow (>$7FFFFFFFFFFFFFFF) -> try floating point
if AllowVarDouble then
goto dbl else begin
result:= false;
exit;
end;
if (VInt64<=high(integer)) and (VInt64>=low(integer)) then
VType := varInteger else
VType := varInt64;
result := true;
exit;
end;
varCurrency: begin
VInt64 := StrToCurr64(JSON);
VType := varCurrency;
result := true;
exit;
end;
varDouble: begin
dbl: VDouble := GetExtended(JSON,err);
if err=0 then begin
VType := varDouble;
result := true;
exit;
end;
end;
end;
end;
result := false;
end;
procedure JSONToVariantInPlace(var Value: variant; JSON: PUTF8Char;
Options: TDocVariantOptions; AllowDouble: boolean);
begin
if (JSON<>nil) and (JSON^<>#0) then
GetJSONToAnyVariant(Value,JSON,nil,@Options,AllowDouble) else
VarClear(Value);
end;
function JSONToVariant(const JSON: RawUTF8; Options: TDocVariantOptions;
AllowDouble: boolean): variant;
var tmp: TSynTempBuffer;
begin
tmp.Init(JSON); // temp copy before in-place decoding
try
JSONToVariantInPlace(result,tmp.buf,Options,AllowDouble);
finally
tmp.Done;
end;
end;
procedure TextToVariant(const aValue: RawUTF8; AllowVarDouble: boolean;
out aDest: variant);
begin
if not GetNumericVariantFromJSON(pointer(aValue),TVarData(aDest),AllowVarDouble) then
RawUTF8ToVariant(aValue,aDest);
end;
function GetNextItemToVariant(var P: PUTF8Char; out Value: Variant;
Sep: AnsiChar; AllowDouble: boolean): boolean;
var temp: RawUTF8;
begin
if P=nil then
result := false else begin
GetNextItem(P,Sep,temp);
if not GetNumericVariantFromJSON(pointer(temp),TVarData(Value),AllowDouble) then
RawUTF8ToVariant(temp,Value);
result := true;
end;
end;
function GetVariantFromNotStringJSON(JSON: PUTF8Char; var Value: TVarData;
AllowDouble: boolean): boolean;
begin
if JSON<>nil then
while (JSON^<=' ') and (JSON^<>#0) do inc(JSON);
if (JSON=nil) or
((PInteger(JSON)^=NULL_LOW) and (jcEndOfJSONValueField in JSON_CHARS[JSON[4]])) then
Value.VType := varNull else
if (PInteger(JSON)^=FALSE_LOW) and (JSON[4]='e') and
(jcEndOfJSONValueField in JSON_CHARS[JSON[5]]) then begin
Value.VType := varBoolean;
Value.VBoolean := false;
end else
if (PInteger(JSON)^=TRUE_LOW) and (jcEndOfJSONValueField in JSON_CHARS[JSON[4]]) then begin
Value.VType := varBoolean;
Value.VBoolean := true;
end else
if not GetNumericVariantFromJSON(JSON,Value,AllowDouble) then begin
result := false;
exit;
end;
result := true;
end;
procedure GetVariantFromJSON(JSON: PUTF8Char; wasString: Boolean; var Value: variant;
TryCustomVariants: PDocVariantOptions; AllowDouble: boolean);
begin
// first handle any strict-JSON syntax objects or arrays into custom variants
// (e.g. when called directly from TSQLPropInfoRTTIVariant.SetValue)
if (TryCustomVariants<>nil) and (JSON<>nil) then
if (GotoNextNotSpace(JSON)^ in ['{','[']) and not wasString then begin
GetJSONToAnyVariant(Value,JSON,nil,TryCustomVariants,AllowDouble);
exit;
end else
AllowDouble := dvoAllowDoubleValue in TryCustomVariants^;
// handle simple text or numerical values
VarClear(Value);
if not wasString and GetVariantFromNotStringJSON(JSON,TVarData(Value),AllowDouble) then
exit;
with TVarData(Value) do begin
// found no numerical value -> return a string in the expected format
VType := varString;
VString := nil; // avoid GPF below when assigning a string variable to VAny
FastSetString(RawUTF8(VString),JSON,StrLen(JSON));
end;
end;
{$ifndef FPC} // better not try it with FPC - rely on the current implementation
function ParseParamPointer(P: pointer; aType: cardinal; var Value: TVarData): pointer;
var Size: Cardinal;
ByRef: Boolean;
V: Variant absolute Value;
const TYPE_BYREF = 128;
TYPE_BYREF_MASK = TYPE_BYREF-1;
begin // this code should copy parameters without any reference count handling
ZeroFill(@Value); // TVarData is expected to be bulk stack: no VarClear needed
ByRef := (aType and TYPE_BYREF)<>0;
Size := SizeOf(pointer);
case aType and TYPE_BYREF_MASK of
varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord, varSingle: begin
if ByRef then
P := pointer(P^);
Value.VType := aType and TYPE_BYREF_MASK;
Value.VInteger := PInteger(P)^;
{$ifdef CPU64}
if not ByRef then
Size := SizeOf(Integer);
{$endif}
end;
varDouble, varCurrency, varDate, varInt64, varWord64, varOleStr: begin
if ByRef then
P := pointer(P^);
Value.VType := aType and TYPE_BYREF_MASK;
Value.VInt64 := PInt64(P)^;
{$ifndef CPU64}
if not ByRef then
Size := SizeOf(Int64);
{$endif}
end;
varStrArg: begin
if ByRef then
P := pointer(P^);
Value.VType := varString;
Value.VString := PPointer(P)^;
end;
{$ifdef HASVARUSTRARG}
varUStrArg: begin
if ByRef then
P := pointer(P^);
Value.VType := varUString;
Value.VUString := PPointer(P)^;
end;
{$endif}
varBoolean:
if ByRef then
V := PWordBool(pointer(P^))^ else
V := PWordBool(P)^;
varVariant:
{$ifdef CPU64} // circumvent Delphi x64 compiler oddiness
Value := PVarData(pointer(P^))^
{$else}
if ByRef then
Value := PVarData(pointer(P^))^ else begin
Value := PVarData(P)^;
Size := SizeOf(Value);
end;
{$endif}
else
raise EInvalidCast.CreateFmt('ParseParamPointer: Invalid VarType=%d',
[aType and TYPE_BYREF_MASK]);
end;
result := PAnsiChar(P)+Size;
end;
var
LastDispInvokeType: TSynInvokeableVariantType;
procedure SynVarDispProc(Result: PVarData; const Instance: TVarData;
CallDesc: PCallDesc; Params: Pointer); cdecl;
const DO_PROP = 1; GET_PROP = 2; SET_PROP = 4;
var Value: TVarData;
Handler: TSynInvokeableVariantType;
CacheDispInvokeType: TSynInvokeableVariantType; // to be thread-safe
begin
if Instance.VType=varByRef or varVariant then // handle By Ref variants
SynVarDispProc(Result,PVarData(Instance.VPointer)^,CallDesc,Params) else begin
if Result<>nil then
VarClear(Variant(Result^));
case Instance.VType of
varDispatch, varDispatch or varByRef,
varUnknown, varUnknown or varByRef, varAny:
// process Ole Automation variants
if Assigned(VarDispProc) then
VarDispProc(pointer(Result),Variant(Instance),CallDesc,@Params);
else begin
// first we check for our own TSynInvokeableVariantType types
if SynVariantTypes<>nil then begin
// simple cache for the latest type: most gets are grouped
CacheDispInvokeType := LastDispInvokeType;
if (CacheDispInvokeType<>nil) and
(CacheDispInvokeType.VarType=TVarData(Instance).VType) and
(CallDesc^.CallType in [GET_PROP, DO_PROP]) and
(Result<>nil) and (CallDesc^.ArgCount=0) then begin
CacheDispInvokeType.IntGet(Result^,Instance,
@CallDesc^.ArgTypes[0],StrLen(@CallDesc^.ArgTypes[0]));
exit;
end;
end;
// handle any custom variant type
if FindCustomVariantType(Instance.VType,TCustomVariantType(Handler)) then begin
if Handler.InheritsFrom(TSynInvokeableVariantType) then
case CallDesc^.CallType of
GET_PROP, DO_PROP: // fast direct call of our IntGet() virtual method
if (Result<>nil) and (CallDesc^.ArgCount=0) then begin
Handler.IntGet(Result^,Instance,
@CallDesc^.ArgTypes[0],StrLen(@CallDesc^.ArgTypes[0]));
LastDispInvokeType := Handler; // speed up in loop
exit;
end;
SET_PROP: // fast direct call of our IntSet() virtual method
if (Result=nil) and (CallDesc^.ArgCount=1) then begin
ParseParamPointer(@Params,CallDesc^.ArgTypes[0],Value);
Handler.IntSet(Instance,Value,
@CallDesc^.ArgTypes[1],StrLen(@CallDesc^.ArgTypes[1]));
exit;
end;
end;
// here we call the default code handling custom types
Handler.DispInvoke({$ifdef DELPHI6OROLDER}Result^{$else}Result{$endif},
Instance,CallDesc,@Params)
end else
raise EInvalidOp.CreateFmt('Invalid variant type %d invoke',[Instance.VType]);
end;
end;
end;
end;
function VariantsDispInvokeAddress: pointer;
asm
{$ifdef CPU64}
mov rax,offset Variants.@DispInvoke
{$else}
mov eax,offset Variants.@DispInvoke
{$endif}
end;
{$ifdef DOPATCHTRTL}
{$define DOPATCHDISPINVOKE} // much faster late-binding process for our types
{$endif}
{$ifdef CPU64}
{$define DOPATCHDISPINVOKE}
// we NEED our patched DispInvoke to circumvent some Delphi bugs on Win64
{$endif}
{$ifdef DELPHI6OROLDER}
{$define DOPATCHDISPINVOKE}
// to circumvent LIdent := Uppercase() in TInvokeableVariantType.DispInvoke()
{$endif}
{$endif FPC}
function SynRegisterCustomVariantType(aClass: TSynInvokeableVariantTypeClass): TSynInvokeableVariantType;
var i: PtrInt;
{$ifdef DOPATCHDISPINVOKE}
{$ifdef NOVARCOPYPROC}
VarMgr: TVariantManager;
{$endif}
{$endif}
begin
{$ifdef DOPATCHDISPINVOKE}
if SynVariantTypes=nil then begin
{$ifndef CPU64} // we NEED our patched RTL on Win64
if DebugHook=0 then // patch VCL/RTL only outside debugging
{$endif} begin
{$ifdef NOVARCOPYPROC}
GetVariantManager(VarMgr);
VarMgr.DispInvoke := @SynVarDispProc;
SetVariantManager(VarMgr);
{$else}
RedirectCode(VariantsDispInvokeAddress,@SynVarDispProc);
{$endif NOVARCOPYPROC}
end;
end else
{$endif DOPATCHDISPINVOKE}
for i := 0 to length(SynVariantTypes)-1 do
if PPointer(SynVariantTypes[i])^=pointer(aClass) then begin
result := SynVariantTypes[i]; // returns already registered instance
exit;
end;
result := aClass.Create; // register variant type
ObjArrayAdd(SynVariantTypes,result);
end;
function VariantDynArrayToJSON(const V: TVariantDynArray): RawUTF8;
var tmp: TDocVariantData;
begin
tmp.InitArrayFromVariants(V);
result := tmp.ToJSON;
end;
function JSONToVariantDynArray(const JSON: RawUTF8): TVariantDynArray;
var tmp: TDocVariantData;
begin
tmp.InitJSON(JSON,JSON_OPTIONS_FAST);
result := tmp.VValue;
end;
function ValuesToVariantDynArray(const items: array of const): TVariantDynArray;
var tmp: TDocVariantData;
begin
tmp.InitArray(items,JSON_OPTIONS_FAST);
result := tmp.VValue;
end;
{ TDocVariantData }
function TDocVariantData.GetKind: TDocVariantKind;
var opt: TDocVariantOptions;
begin
opt := VOptions;
if dvoIsArray in opt then
result := dvArray else
if dvoIsObject in opt then
result := dvObject else
result := dvUndefined;
end;
function DocVariantData(const DocVariant: variant): PDocVariantData;
var docv,vt: integer;
begin
result := @DocVariant;
docv := DocVariantVType;
vt := result^.VType;
if vt=docv then
exit else
if vt=varByRef or varVariant then begin
result := PVarData(result)^.VPointer;
if integer(result^.VType)=docv then
exit;
end;
raise EDocVariant.CreateUTF8('DocVariantType.Data(%<>TDocVariant)',[ord(result^.VType)]);
end;
function _Safe(const DocVariant: variant): PDocVariantData;
{$ifdef FPC_OR_PUREPASCAL}
var docv,vt: integer;
begin
result := @DocVariant;
docv := DocVariantVType;
vt := result^.VType;
if vt=docv then
exit else
if vt=varByRef or varVariant then begin
result := PVarData(result)^.VPointer;
if integer(result^.VType)=docv then
exit;
end;
result := @DocVariantDataFake;
end;
{$else}
asm
mov ecx,DocVariantVType
movzx edx,word ptr [eax].TVarData.VType
cmp edx,ecx
jne @by
ret
@ptr: mov eax,[eax].TVarData.VPointer
movzx edx,word ptr [eax].TVarData.VType
cmp edx,ecx
je @ok
@by: cmp edx,varByRef or varVariant
je @ptr
lea eax,[DocVariantDataFake]
@ok:
end;
{$endif}
function _Safe(const DocVariant: variant; ExpectedKind: TDocVariantKind): PDocVariantData;
var o: TDocVariantOptions;
begin
result := _Safe(DocVariant);
o := result^.VOptions;
if dvoIsArray in o then begin
if ExpectedKind=dvArray then
exit;
end else if (dvoIsObject in o) and (ExpectedKind=dvObject) then
exit;
raise EDocVariant.CreateUTF8('_Safe(%)?',[ToText(ExpectedKind)^]);
end;
function _CSV(const DocVariantOrString: variant): RawUTF8;
begin
with _Safe(DocVariantOrString)^ do
if dvoIsArray in VOptions then
result := ToCSV else
if (dvoIsObject in VOptions) or (TDocVariantData(DocVariantOrString).VType<=varNull) or
not VariantToUTF8(DocVariantOrString,result) then
result := ''; // VariantToUTF8() returns 'null' for empty/null
end;
function TDocVariantData.GetValueIndex(const aName: RawUTF8): integer;
begin
result := GetValueIndex(Pointer(aName),Length(aName),dvoNameCaseSensitive in VOptions);
end;
function TDocVariantData.GetCapacity: integer;
begin
result := length(VValue);
end;
function TDocVariant.InternNames: TRawUTF8Interning;
begin
if fInternNames=nil then
fInternNames := TRawUTF8Interning.Create;
result := fInternNames;
end;
function TDocVariant.InternValues: TRawUTF8Interning;
begin
if fInternValues=nil then
fInternValues := TRawUTF8Interning.Create;
result := fInternValues;
end;
procedure TDocVariantData.SetOptions(const opt: TDocVariantOptions);
begin
VOptions := (opt-[dvoIsArray,dvoIsObject])+(VOptions*[dvoIsArray,dvoIsObject]);
end;
procedure TDocVariantData.Init(aOptions: TDocVariantOptions; aKind: TDocVariantKind);
begin
aOptions := aOptions-[dvoIsArray,dvoIsObject];
case aKind of
dvArray: include(aOptions,dvoIsArray);
dvObject: include(aOptions,dvoIsObject);
end;
ZeroFill(@self);
VType := DocVariantVType;
VOptions := aOptions;
end;
procedure TDocVariantData.InitFast;
begin
ZeroFill(@self);
VType := DocVariantVType;
VOptions := JSON_OPTIONS_FAST;
end;
procedure TDocVariantData.InitFast(InitialCapacity: integer; aKind: TDocVariantKind);
begin
InitFast;
case aKind of
dvArray: include(VOptions,dvoIsArray);
dvObject: include(VOptions,dvoIsObject);
end;
if aKind=dvObject then
SetLength(VName,InitialCapacity);
SetLength(VValue,InitialCapacity);
end;
procedure TDocVariantData.InitObject(const NameValuePairs: array of const;
aOptions: TDocVariantOptions=[]);
begin
Init(aOptions,dvObject);
AddNameValuesToObject(NameValuePairs);
end;
procedure TDocVariantData.AddNameValuesToObject(const NameValuePairs: array of const);
var n,arg: PtrInt;
tmp: variant;
begin
n := length(NameValuePairs);
if (n=0) or (n and 1=1) or (dvoIsArray in VOptions) then
exit; // nothing to add
include(VOptions,dvoIsObject);
n := n shr 1;
if length(VValue)<VCount+n then begin
SetLength(VValue,VCount+n);
SetLength(VName,VCount+n);
end;
for arg := 0 to n-1 do begin
VarRecToUTF8(NameValuePairs[arg*2],VName[arg+VCount]);
if dvoInternNames in VOptions then
DocVariantType.InternNames.UniqueText(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;
if dvoInternValues in VOptions then
DocVariantType.InternValues.UniqueVariant(VValue[arg+VCount]);
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 (dvoIsArray in VOptions) 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; RecursiveUpdate: boolean);
var n, idx: integer;
new: PDocVariantData;
wasAdded: boolean;
begin
new := _Safe(NewValues);
if not(dvoIsArray in VOptions) and not(dvoIsArray in new^.VOptions) then
for n := 0 to new^.Count-1 do begin
idx := AddOrUpdateValue(new^.names[n],new^.Values[n],@wasAdded,OnlyAddMissing);
if RecursiveUpdate and not wasAdded then
TDocVariantData(Values[idx]).AddOrUpdateObject(new^.Values[n],OnlyAddMissing,true);
end;
end;
procedure TDocVariantData.InitArray(const 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 VOptions then
for arg := 0 to high(Items) do
VarRecToVariant(Items[arg],VValue[arg]) else
for arg := 0 to high(Items) do begin
VarRecToVariant(Items[arg],tmp);
SetVariantByValue(tmp,VValue[arg]);
end;
end;
end;
procedure TDocVariantData.InitArrayFromVariants(const Items: TVariantDynArray;
aOptions: TDocVariantOptions; ItemsCopiedByReference: boolean);
begin
if Items=nil then
VType := varNull else begin
Init(aOptions,dvArray);
VCount := length(Items);
VValue := Items; // fast by-reference copy of VValue[]
if not ItemsCopiedByReference then
InitCopy(variant(self),aOptions);
end;
end;
procedure TDocVariantData.InitArrayFromObjArray(const ObjArray;
aOptions: TDocVariantOptions; aWriterOptions: TTextWriterWriteObjectOptions);
var ndx: integer;
Items: TObjectDynArray absolute ObjArray;
begin
if Items=nil then
VType := varNull else begin
Init(aOptions,dvArray);
VCount := length(Items);
SetLength(VValue,VCount);
for ndx := 0 to VCount-1 do
ObjectToVariant(Items[ndx],VValue[ndx],aWriterOptions);
end;
end;
procedure TDocVariantData.InitArrayFrom(const Items: TRawUTF8DynArray;
aOptions: TDocVariantOptions);
var ndx: integer;
begin
if Items=nil then
VType := varNull else begin
Init(aOptions,dvArray);
VCount := length(Items);
SetLength(VValue,VCount);
for ndx := 0 to VCount-1 do
RawUTF8ToVariant(Items[ndx],VValue[ndx]);
end;
end;
procedure TDocVariantData.InitArrayFrom(const Items: TIntegerDynArray;
aOptions: TDocVariantOptions);
var ndx: integer;
begin
if Items=nil then
VType := varNull else begin
Init(aOptions,dvArray);
VCount := length(Items);
SetLength(VValue,VCount);
for ndx := 0 to VCount-1 do
VValue[ndx] := Items[ndx];
end;
end;
procedure TDocVariantData.InitArrayFrom(const Items: TInt64DynArray;
aOptions: TDocVariantOptions);
var ndx: integer;
begin
if Items=nil then
VType := varNull else begin
Init(aOptions,dvArray);
VCount := length(Items);
SetLength(VValue,VCount);
for ndx := 0 to VCount-1 do
VValue[ndx] := Items[ndx];
end;
end;
procedure TDocVariantData.InitFromTypeInfo(const aValue; aTypeInfo: pointer;
aEnumSetsAsText: boolean; aOptions: TDocVariantOptions);
var tmp: RawUTF8;
begin
tmp := SaveJSON(aValue,aTypeInfo,aEnumSetsAsText);
InitJSONInPlace(pointer(tmp),aOptions);
end;
procedure TDocVariantData.InitObjectFromVariants(const aNames: TRawUTF8DynArray;
const aValues: TVariantDynArray; aOptions: TDocVariantOptions);
begin
if (aNames=nil) or (aValues=nil) or (length(aNames)<>length(aValues)) then
VType := varNull else begin
Init(aOptions,dvObject);
VCount := length(aNames);
VName := aNames; // fast by-reference copy of VName[] and VValue[]
VValue := aValues;
end;
end;
procedure TDocVariantData.InitObjectFromPath(const aPath: RawUTF8; const aValue: variant;
aOptions: TDocVariantOptions);
var right: RawUTF8;
begin
if aPath='' then
VType := varNull else begin
Init(aOptions,dvObject);
VCount := 1;
SetLength(VName,1);
SetLength(VValue,1);
split(aPath,'.',VName[0],right);
if right='' then
VValue[0] := aValue else
PDocVariantData(@VValue[0])^.InitObjectFromPath(right,aValue,aOptions);
end;
end;
function TDocVariantData.InitJSONInPlace(JSON: PUTF8Char;
aOptions: TDocVariantOptions; aEndOfObject: PUTF8Char): PUTF8Char;
var EndOfObject: AnsiChar;
Name: PUTF8Char;
NameLen, n: integer;
intnames, intvalues: TRawUTF8Interning;
begin
Init(aOptions);
result := nil;
if JSON=nil then
exit;
if dvoInternValues in VOptions then
intvalues := DocVariantType.InternValues else
intvalues := nil;
while (JSON^<=' ') and (JSON^<>#0) do inc(JSON);
case JSON^ of
'[': begin
repeat inc(JSON); if JSON^=#0 then exit; until JSON^>' ';
n := JSONArrayCount(JSON); // may be slow if JSON is huge (not very common)
if n<0 then
exit; // invalid content
include(VOptions,dvoIsArray);
if n>0 then begin
SetLength(VValue,n);
repeat
if VCount>=n then
exit; // unexpected array size means invalid JSON
GetJSONToAnyVariant(VValue[VCount],JSON,@EndOfObject,@VOptions,false);
if JSON=nil then
if EndOfObject=']' then // valid array end
JSON := @NULCHAR else
exit; // invalid input
if intvalues<>nil then
intvalues.UniqueVariant(VValue[VCount]);
inc(VCount);
until EndOfObject=']';
end else
if JSON^=']' then // n=0
repeat inc(JSON) until (JSON^=#0) or (JSON^>' ') else
exit;
end;
'{': begin
repeat inc(JSON); if JSON^=#0 then exit; until JSON^>' ';
n := JSONObjectPropCount(JSON); // may be slow if JSON is huge (not very common)
if n<0 then
exit; // invalid content
include(VOptions,dvoIsObject);
if dvoInternNames in VOptions then
intnames := DocVariantType.InternNames else
intnames := nil;
if n>0 then begin
SetLength(VValue,n);
SetLength(VName,n);
repeat
if VCount>=n then
exit; // unexpected object size means invalid JSON
// see http://docs.mongodb.org/manual/reference/mongodb-extended-json
Name := GetJSONPropName(JSON,@NameLen);
if Name=nil then
exit;
FastSetString(VName[VCount],Name,NameLen);
if intnames<>nil then
intnames.UniqueText(VName[VCount]);
GetJSONToAnyVariant(VValue[VCount],JSON,@EndOfObject,@VOptions,false);
if JSON=nil then
if EndOfObject='}' then // valid object end
JSON := @NULCHAR else
exit; // invalid input
if intvalues<>nil then
intvalues.UniqueVariant(VValue[VCount]);
inc(VCount);
until EndOfObject='}';
end else
if JSON^='}' then // n=0
repeat inc(JSON) until (JSON^=#0) or (JSON^>' ') else
exit;
end;
'n','N': begin
if IdemPChar(JSON+1,'ULL') then begin
include(VOptions,dvoIsObject);
result := GotoNextNotSpace(JSON+4);
end;
exit;
end;
else exit;
end;
while (JSON^<=' ') and (JSON^<>#0) do inc(JSON);
if aEndOfObject<>nil then
aEndOfObject^ := JSON^;
if JSON^<>#0 then
repeat inc(JSON) until (JSON^=#0) or (JSON^>' ');
result := JSON; // indicates successfully parsed
end;
function TDocVariantData.InitJSON(const JSON: RawUTF8;
aOptions: TDocVariantOptions): boolean;
var tmp: TSynTempBuffer;
begin
if JSON='' then
result := false else begin
tmp.Init(JSON);
try
result := InitJSONInPlace(tmp.buf,aOptions)<>nil;
finally
tmp.Done;
end;
end;
end;
function TDocVariantData.InitJSONFromFile(const JsonFile: TFileName;
aOptions: TDocVariantOptions; RemoveComments: boolean): boolean;
var content: RawUTF8;
begin
content := AnyTextFileToRawUTF8(JsonFile,true);
if RemoveComments then
RemoveCommentsFromJSON(pointer(content));
result := InitJSONInPlace(pointer(content),aOptions)<>nil;
end;
procedure TDocVariantData.InitCSV(CSV: PUTF8Char; aOptions: TDocVariantOptions;
NameValueSep, ItemSep: AnsiChar; DoTrim: boolean);
var n,v: RawUTF8;
val: variant;
begin
Init(aOptions,dvObject);
while CSV<>nil do begin
GetNextItem(CSV,NameValueSep,n);
if ItemSep=#10 then
GetNextItemTrimedCRLF(CSV,v) else
GetNextItem(CSV,ItemSep,v);
if DoTrim then
v := trim(v);
if n='' then
break;
RawUTF8ToVariant(v,val);
AddValue(n,val);
end;
end;
procedure TDocVariantData.InitCSV(const CSV: RawUTF8; aOptions: TDocVariantOptions;
NameValueSep, ItemSep: AnsiChar; DoTrim: boolean);
begin
InitCSV(pointer(CSV),aOptions,NameValueSep,ItemSep,DoTrim);
end;
procedure TDocVariantData.InitCopy(const SourceDocVariant: variant;
aOptions: TDocVariantOptions);
var ndx,vt: integer;
Source: PDocVariantData;
SourceVValue: TVariantDynArray;
Handler: TCustomVariantType;
v: PVarData;
begin
with TVarData(SourceDocVariant) do
if integer(VType)=varByRef or varVariant then
Source := VPointer else
Source := @SourceDocVariant;
if integer(Source^.VType)<>DocVariantVType then
raise ESynException.CreateUTF8('No TDocVariant for InitCopy(%)',[ord(Source.VType)]);
SourceVValue := Source^.VValue; // local fast per-reference copy
if Source<>@self then begin
VType := Source^.VType;
VCount := Source^.VCount;
pointer(VName) := nil; // avoid GPF
pointer(VValue) := nil;
aOptions := aOptions-[dvoIsArray,dvoIsObject]; // may not be same as Source
if dvoIsArray in Source^.VOptions then
include(aOptions,dvoIsArray) else
if dvoIsObject in Source^.VOptions then begin
include(aOptions,dvoIsObject);
SetLength(VName,VCount);
for ndx := 0 to VCount-1 do
VName[ndx] := Source^.VName[ndx]; // manual copy is needed
if dvoInternNames in aOptions then
with DocVariantType.InternNames do
for ndx := 0 to VCount-1 do
UniqueText(VName[ndx]);
end;
VOptions := aOptions;
end else begin
SetOptions(aOptions);
VariantDynArrayClear(VValue); // full copy of all values
end;
if VCount>0 then begin
SetLength(VValue,VCount);
for ndx := 0 to VCount-1 do begin
v := @SourceVValue[ndx];
repeat
vt := v^.VType;
if vt<>varByRef or varVariant then
break;
v := v^.VPointer;
until false;
if vt<=varNativeString then // simple string/number types copy
VValue[ndx] := variant(v^) else
if vt=DocVariantVType then // direct recursive copy for TDocVariant
TDocVariantData(VValue[ndx]).InitCopy(variant(v^),VOptions) else
if FindCustomVariantType(vt,Handler) then
if Handler.InheritsFrom(TSynInvokeableVariantType) then
TSynInvokeableVariantType(Handler).CopyByValue(TVarData(VValue[ndx]),v^) else
Handler.Copy(TVarData(VValue[ndx]),v^,false) else
VValue[ndx] := variant(v^); // default copy
end;
if dvoInternValues in VOptions then
with DocVariantType.InternValues do
for ndx := 0 to VCount-1 do
UniqueVariant(VValue[ndx]);
end;
VariantDynArrayClear(SourceVValue);
end;
procedure TDocVariantData.Clear;
begin
if integer(VType)=DocVariantVType then begin
PInteger(@VType)^ := 0;
RawUTF8DynArrayClear(VName);
VariantDynArrayClear(VValue);
VCount := 0;
end else
VarClear(variant(self));
end;
procedure TDocVariantData.Reset;
var backup: TDocVariantOptions;
begin
if VCount=0 then
exit;
backup := VOptions-[dvoIsArray,dvoIsObject];
DocVariantType.Clear(TVarData(self));
VType := DocVariantVType;
VOptions := backup;
end;
procedure TDocVariantData.FillZero;
var ndx: integer;
begin
for ndx := 0 to VCount-1 do
SynCommons.FillZero(VValue[ndx]);
Reset;
end;
procedure TDocVariantData.SetCount(aCount: integer);
begin
VCount := aCount;
end;
function TDocVariantData.InternalAdd(const aName: RawUTF8): integer;
var len: integer;
begin
if aName<>'' then begin
if dvoIsArray in VOptions then
raise EDocVariant.CreateUTF8('Add: Unexpected [%] object property in an array',[aName]);
if not(dvoIsObject in VOptions) then begin
VType := DocVariantVType; // may not be set yet
include(VOptions,dvoIsObject);
end;
end else begin
if dvoIsObject in VOptions then
raise EDocVariant.Create('Add: Unexpected array item in an object');
if not(dvoIsArray in VOptions) then begin
VType := DocVariantVType; // may not be set yet
include(VOptions,dvoIsArray);
end;
end;
len := length(VValue);
if VCount>=len then begin
len := NextGrow(VCount);
SetLength(VValue,len);
end;
if aName<>'' then begin
if Length(VName)<>len then
SetLength(VName,len);
if dvoInternNames in VOptions then begin // inlined InternNames method
if DocVariantType.fInternNames=nil then
DocVariantType.fInternNames := TRawUTF8Interning.Create;
DocVariantType.fInternNames.Unique(VName[VCount],aName);
end else
VName[VCount] := aName;
end;
result := VCount;
inc(VCount);
end;
procedure TDocVariantData.SetCapacity(aValue: integer);
begin
if dvoIsObject in VOptions then
SetLength(VName,aValue);
SetLength(VValue,aValue);
end;
function TDocVariantData.AddValue(const aName: RawUTF8;
const aValue: variant; aValueOwned: boolean): integer;
begin
if dvoCheckForDuplicatedNames in VOptions then begin
result := GetValueIndex(aName);
if result>=0 then
raise EDocVariant.CreateUTF8('AddValue: Duplicated [%] name',[aName]);
end;
result := InternalAdd(aName);
if aValueOwned then
VValue[result] := aValue else
SetVariantByValue(aValue,VValue[result]);
if dvoInternValues in VOptions then
DocVariantType.InternValues.UniqueVariant(VValue[result]);
end;
function TDocVariantData.AddValue(aName: PUTF8Char; aNameLen: integer;
const aValue: variant; aValueOwned: boolean): integer;
var tmp: RawUTF8;
begin
FastSetString(tmp,aName,aNameLen);
result := AddValue(tmp,aValue,aValueOwned);
end;
function TDocVariantData.AddValueFromText(const aName,aValue: RawUTF8;
Update, AllowVarDouble: boolean): integer;
begin
if aName='' then begin
result := -1;
exit;
end;
result := GetValueIndex(aName);
if not Update and (dvoCheckForDuplicatedNames in VOptions) and (result>=0) then
raise EDocVariant.CreateUTF8('AddValueFromText: Duplicated [%] name',[aName]);
if result<0 then
result := InternalAdd(aName);
VarClear(VValue[result]);
if not GetNumericVariantFromJSON(pointer(aValue),TVarData(VValue[result]),AllowVarDouble) then
if dvoInternValues in VOptions then
DocVariantType.InternValues.UniqueVariant(VValue[result],aValue) else
RawUTF8ToVariant(aValue,VValue[result]);
end;
procedure TDocVariantData.AddByPath(const aSource: TDocVariantData;
const aPaths: array of RawUTF8);
var p,added: integer;
v: TVarData;
begin
if (aSource.Count=0) or not(dvoIsObject in aSource.VOptions) or
(dvoIsArray in VOptions) then
exit;
for p := 0 to High(aPaths) do begin
DocVariantType.Lookup(v,TVarData(aSource),pointer(aPaths[p]));
if integer(v.VType)<varNull then
continue; // path not found
added := InternalAdd(aPaths[p]);
PVarData(@VValue[added])^ := v;
if dvoInternValues in VOptions then
DocVariantType.InternValues.UniqueVariant(VValue[added]);
end;
end;
procedure TDocVariantData.AddFrom(const aDocVariant: Variant);
var src: PDocVariantData;
ndx: integer;
begin
src := _Safe(aDocVariant);
if src^.Count=0 then
exit; // nothing to add
if dvoIsArray in src^.VOptions then
// add array items
if dvoIsObject in VOptions then // types should match
exit else
for ndx := 0 to src^.Count-1 do
AddItem(src^.VValue[ndx]) else
// add object items
if dvoIsArray in VOptions then // types should match
exit else
for ndx := 0 to src^.Count-1 do
AddValue(src^.VName[ndx],src^.VValue[ndx]);
end;
procedure TDocVariantData.AddOrUpdateFrom(const aDocVariant: Variant; aOnlyAddMissing: boolean);
var src: PDocVariantData;
ndx: integer;
begin
src := _Safe(aDocVariant,dvObject);
for ndx := 0 to src^.Count-1 do
AddOrUpdateValue(src^.VName[ndx],src^.VValue[ndx],nil,aOnlyAddMissing);
end;
function TDocVariantData.AddItem(const aValue: variant): integer;
begin
result := InternalAdd('');
SetVariantByValue(aValue,VValue[result]);
if dvoInternValues in VOptions then
DocVariantType.InternValues.UniqueVariant(VValue[result]);
end;
function TDocVariantData.AddItemFromText(const aValue: RawUTF8;
AllowVarDouble: boolean): integer;
begin
result := InternalAdd('');
if not GetNumericVariantFromJSON(pointer(aValue),TVarData(VValue[result]),AllowVarDouble) then
if dvoInternValues in VOptions then
DocVariantType.InternValues.UniqueVariant(VValue[result],aValue) else
RawUTF8ToVariant(aValue,VValue[result]);
end;
function TDocVariantData.AddItemText(const aValue: RawUTF8): integer;
begin
result := InternalAdd('');
if dvoInternValues in VOptions then
DocVariantType.InternValues.UniqueVariant(VValue[result],aValue) else
RawUTF8ToVariant(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('');
VarRecToVariant(aValue[ndx],VValue[added]);
if dvoInternValues in VOptions then
DocVariantType.InternValues.UniqueVariant(VValue[added]);
end;
end;
function TDocVariantData.SearchItemByProp(const aPropName,aPropValue: RawUTF8;
aPropValueCaseSensitive: boolean): integer;
var ndx: integer;
begin
if dvoIsObject in VOptions then begin
result := GetValueIndex(aPropName);
if (result>=0) and VariantEquals(VValue[result],aPropValue,aPropValueCaseSensitive) then
exit;
end else
if dvoIsArray in VOptions then
for result := 0 to VCount-1 do
with _Safe(VValue[result])^ do
if dvoIsObject in VOptions then begin
ndx := GetValueIndex(aPropName);
if (ndx>=0) and VariantEquals(VValue[ndx],aPropValue,aPropValueCaseSensitive) then
exit;
end;
result := -1;
end;
function TDocVariantData.SearchItemByProp(const aPropNameFmt: RawUTF8;
const aPropNameArgs: array of const; const aPropValue: RawUTF8;
aPropValueCaseSensitive: boolean): integer;
var name: RawUTF8;
begin
FormatUTF8(aPropNameFmt,aPropNameArgs,name);
result := SearchItemByProp(name,aPropValue,aPropValueCaseSensitive);
end;
function TDocVariantData.SearchItemByValue(const aValue: Variant;
CaseInsensitive: boolean; StartIndex: integer): integer;
begin
for result := StartIndex to VCount-1 do
if SortDynArrayVariantComp(TVarData(VValue[result]),TVarData(aValue),CaseInsensitive)=0 then
exit;
result := -1;
end;
type
TQuickSortDocVariant = object
names: PPointerArray;
values: PVariantArray;
nameCompare: TUTF8Compare;
valueCompare: TVariantCompare;
procedure SortByName(L, R: PtrInt);
procedure SortByValue(L, R: PtrInt);
end;
procedure TQuickSortDocVariant.SortByName(L, R: PtrInt);
var I, J, P: PtrInt;
pivot: pointer;
begin
if L<R then
repeat
I := L; J := R;
P := (L + R) shr 1;
repeat
pivot := names[P];
while nameCompare(names[I],pivot)<0 do Inc(I);
while nameCompare(names[J],pivot)>0 do Dec(J);
if I <= J then begin
if I <> J then begin
ExchgPointer(@names[I],@names[J]);
ExchgVariant(@values[I],@values[J]);
end;
if P = I then P := J else if P = J then P := I;
inc(I); dec(J);
end;
until I > J;
if J - L < R - I then begin // use recursion only for smaller range
if L < J then
SortByName(L,J);
L := I;
end else begin
if I < R then
SortByName(I,R);
R := J;
end;
until L >= R;
end;
procedure TQuickSortDocVariant.SortByValue(L, R: PtrInt);
var I, J, P: PtrInt;
pivot: PVariant;
begin
if L<R then
repeat
I := L; J := R;
P := (L + R) shr 1;
repeat
pivot := @values[P];
while valueCompare(values[I],pivot^)<0 do Inc(I);
while valueCompare(values[J],pivot^)>0 do Dec(J);
if I <= J then begin
if I <> J then begin
if names<>nil then
ExchgPointer(@names[I],@names[J]);
ExchgVariant(@values[I],@values[J]);
end;
if P = I then P := J else if P = J then P := I;
inc(I); dec(J);
end;
until I > J;
if J - L < R - I then begin // use recursion only for smaller range
if L < J then
SortByValue(L,J);
L := I;
end else begin
if I < R then
SortByValue(I,R);
R := J;
end;
until L >= R;
end;
procedure TDocVariantData.SortByName(Compare: TUTF8Compare);
var qs: TQuickSortDocVariant;
begin
if not(dvoIsObject in VOptions) or (VCount<=0) then
exit;
if Assigned(Compare) then
qs.nameCompare := Compare else
qs.nameCompare := @StrIComp;
qs.names := pointer(VName);
qs.values := pointer(VValue);
qs.SortByName(0,VCount-1);
end;
procedure TDocVariantData.SortByValue(Compare: TVariantCompare);
var qs: TQuickSortDocVariant;
begin
if VCount<=0 then
exit;
if Assigned(Compare) then
qs.valueCompare := Compare else
qs.valueCompare := @VariantCompare;
qs.names := pointer(VName);
qs.values := pointer(VValue);
qs.SortByValue(0,VCount-1);
end;
type
{$ifdef USERECORDWITHMETHODS}TQuickSortDocVariantValuesByField = record
{$else}TQuickSortDocVariantValuesByField = object{$endif}
Lookup: array of PVariant;
Compare: TVariantCompare;
Doc: PDocVariantData;
Reverse: boolean;
procedure Sort(L, R: PtrInt);
end;
procedure TQuickSortDocVariantValuesByField.Sort(L, R: PtrInt);
var I, J, P: PtrInt;
pivot: PVariant;
begin
if L<R then
repeat
I := L; J := R;
P := (L + R) shr 1;
repeat
pivot := Lookup[P];
if Reverse then begin
while Compare(Lookup[I]^,pivot^)<0 do Inc(I);
while Compare(Lookup[J]^,pivot^)>0 do Dec(J);
end
else begin
while Compare(Lookup[I]^,pivot^)>0 do Inc(I);
while Compare(Lookup[J]^,pivot^)<0 do Dec(J);
end;
if I <= J then begin
if I <> J then begin
if Doc.VName<>nil then
ExchgPointer(@Doc.VName[I],@Doc.VName[J]);
ExchgVariant(@Doc.VValue[I],@Doc.VValue[J]);
pivot := Lookup[I];
Lookup[I] := Lookup[J];
Lookup[J] := pivot;
end;
if P = I then P := J else if P = J then P := I;
inc(I); dec(J);
end;
until I > J;
if J - L < R - I then begin // use recursion only for smaller range
if L < J then
Sort(L,J);
L := I;
end else begin
if I < R then
Sort(I,R);
R := J;
end;
until L >= R;
end;
procedure TDocVariantData.SortArrayByField(const aItemPropName: RawUTF8;
aValueCompare: TVariantCompare; aValueCompareReverse: boolean; aNameSortedCompare: TUTF8Compare);
var
QS: TQuickSortDocVariantValuesByField;
p: pointer;
row: PtrInt;
begin
if (VCount<=0) or (aItemPropName='') or not (dvoIsArray in VOptions) then
exit;
if not Assigned(aValueCompare) then
QS.Compare := VariantCompare else
QS.Compare := aValueCompare;
QS.Reverse := aValueCompareReverse;
SetLength(QS.Lookup,VCount);
for row := 0 to VCount-1 do begin // resolve GetPVariantByName(aIdemPropName) once
p := _Safe(VValue[row])^.GetVarData(aItemPropName,aNameSortedCompare);
if p = nil then
p := @NullVarData;
QS.Lookup[row] := p;
end;
QS.Doc := @self;
QS.Sort(0,VCount-1);
end;
procedure TDocVariantData.Reverse;
var arr: TDynArray;
begin
if VCount=0 then
exit;
if VName<>nil then begin
SetLength(VName,VCount);
arr.Init(TypeInfo(TRawUTF8DynArray),VName);
arr.Reverse;
end;
if VValue<>nil then begin
SetLength(VValue,VCount);
arr.Init(TypeInfo(TVariantDynArray),VValue);
arr.Reverse;
end;
end;
function TDocVariantData.Reduce(const aPropNames: array of RawUTF8;
aCaseSensitive,aDoNotAddVoidProp: boolean): variant;
begin
VarClear(result);
Reduce(aPropNames,aCaseSensitive,PDocVariantData(@result)^,aDoNotAddVoidProp);
end;
procedure TDocVariantData.Reduce(const aPropNames: array of RawUTF8;
aCaseSensitive: boolean; out result: TDocVariantData; aDoNotAddVoidProp: boolean);
var ndx,j: integer;
reduced: TDocVariantData;
begin
result.InitFast;
if (VCount=0) or (high(aPropNames)<0) then
exit;
if dvoIsObject in VOptions then begin
if aCaseSensitive then begin
for j := 0 to high(aPropNames) do
for ndx := 0 to VCount-1 do
if VName[ndx]=aPropNames[j] then begin
if not aDoNotAddVoidProp or not VarIsVoid(VValue[ndx]) then
result.AddValue(VName[ndx],VValue[ndx]);
break;
end;
end else
for j := 0 to high(aPropNames) do
for ndx := 0 to VCount-1 do
if IdemPropNameU(VName[ndx],aPropNames[j]) then begin
if not aDoNotAddVoidProp or not VarIsVoid(VValue[ndx]) then
result.AddValue(VName[ndx],VValue[ndx]);
break;
end;
end else
if dvoIsArray in VOptions then
for ndx := 0 to VCount-1 do begin
_Safe(VValue[ndx])^.Reduce(aPropNames,aCaseSensitive,reduced,aDoNotAddVoidProp);
if dvoIsObject in reduced.VOptions then
result.AddItem(variant(reduced));
end;
end;
function TDocVariantData.ReduceAsArray(const aPropName: RawUTF8;
OnReduce: TOnReducePerItem): variant;
begin
VarClear(result);
ReduceAsArray(aPropName,PDocVariantData(@result)^,OnReduce);
end;
procedure TDocVariantData.ReduceAsArray(const aPropName: RawUTF8;
out result: TDocVariantData; OnReduce: TOnReducePerItem);
var ndx,j: integer;
item: PDocVariantData;
begin
result.InitFast;
if (VCount=0) or (aPropName='') or not(dvoIsArray in VOptions) then
exit;
for ndx := 0 to VCount-1 do begin
item := _Safe(VValue[ndx]);
j := item^.GetValueIndex(aPropName);
if j>=0 then
if not Assigned(OnReduce) or OnReduce(item) then
result.AddItem(item^.VValue[j]);
end;
end;
function TDocVariantData.ReduceAsArray(const aPropName: RawUTF8;
OnReduce: TOnReducePerValue): variant;
begin
VarClear(result);
ReduceAsArray(aPropName,PDocVariantData(@result)^,OnReduce);
end;
procedure TDocVariantData.ReduceAsArray(const aPropName: RawUTF8;
out result: TDocVariantData; OnReduce: TOnReducePerValue);
var ndx,j: integer;
item: PDocVariantData;
v: PVariant;
begin
result.InitFast;
if (VCount=0) or (aPropName='') or not(dvoIsArray in VOptions) then
exit;
for ndx := 0 to VCount-1 do begin
item := _Safe(VValue[ndx]);
j := item^.GetValueIndex(aPropName);
if j>=0 then begin
v := @item^.VValue[j];
if not Assigned(OnReduce) or OnReduce(v^) then
result.AddItem(v^);
end;
end;
end;
function TDocVariantData.Rename(const aFromPropName, aToPropName: TRawUTF8DynArray): integer;
var n, p, ndx: integer;
begin
result := 0;
n := length(aFromPropName);
if length(aToPropName)=n then
for p := 0 to n-1 do begin
ndx := GetValueIndex(aFromPropName[p]);
if ndx>=0 then begin
VName[ndx] := aToPropName[p];
inc(result);
end;
end;
end;
function TDocVariantData.FlattenAsNestedObject(const aObjectPropName: RawUTF8): boolean;
var ndx,len: integer;
Up: array[byte] of AnsiChar;
nested: TDocVariantData;
begin // {"p.a1":5,"p.a2":"dfasdfa"} -> {"p":{"a1":5,"a2":"dfasdfa"}}
result := false;
if (VCount=0) or (aObjectPropName='') or not(dvoIsObject in VOptions) then
exit;
PWord(UpperCopy255(Up,aObjectPropName))^ := ord('.'); // e.g. 'P.'
for ndx := 0 to Count-1 do
if not IdemPChar(pointer(VName[ndx]),Up) then
exit; // all fields should match "p.####"
len := length(aObjectPropName)+1;
for ndx := 0 to Count-1 do
system.delete(VName[ndx],1,len);
nested := self;
Clear;
InitObject([aObjectPropName,variant(nested)]);
result := true;
end;
function TDocVariantData.Delete(Index: integer): boolean;
begin
if cardinal(Index)>=cardinal(VCount) then
result := false else begin
dec(VCount);
if VName<>nil then begin
if PDACnt(PtrUInt(VName)-_DAREFCNT)^>1 then
DynArrayMakeUnique(@VName,TypeInfo(TRawUTF8DynArray));
VName[Index] := '';
end;
if PDACnt(PtrUInt(VValue)-_DAREFCNT)^>1 then
DynArrayMakeUnique(@VValue,TypeInfo(TVariantDynArray));
VarClear(VValue[Index]);
if 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;
aPropValueCaseSensitive: boolean): boolean;
var ndx: integer;
begin
ndx := SearchItemByProp(aPropName,aPropValue,aPropValueCaseSensitive);
if ndx<0 then
result := false else
result := Delete(ndx);
end;
function TDocVariantData.DeleteByValue(const aValue: Variant;
CaseInsensitive: boolean): integer;
var ndx: PtrInt;
begin
result := 0;
if VarIsEmptyOrNull(aValue) then begin
for ndx := VCount-1 downto 0 do
if VarDataIsEmptyOrNull(@VValue[ndx]) then begin
Delete(ndx);
inc(result);
end;
end else
for ndx := VCount-1 downto 0 do
if SortDynArrayVariantComp(TVarData(VValue[ndx]),TVarData(aValue),CaseInsensitive)=0 then begin
Delete(ndx);
inc(result);
end;
end;
function TDocVariantData.DeleteByStartName(aStartName: PUTF8Char; aStartNameLen: integer): integer;
var ndx: integer;
upname: array[byte] of AnsiChar;
begin
result := 0;
if aStartNameLen=0 then
aStartNameLen := StrLen(aStartName);
if (VCount=0) or not(dvoIsObject in VOptions) or (aStartNameLen=0) then
exit;
UpperCopy255Buf(upname,aStartName,aStartNameLen)^ := #0;
for ndx := Count-1 downto 0 do
if IdemPChar(pointer(names[ndx]),upname) then begin
Delete(ndx);
inc(result);
end;
end;
function FindNonVoidRawUTF8(n: PPtrInt; name: PUTF8Char; len: TStrLen; count: PtrInt): PtrInt;
begin // FPC does proper inlining in this loop
for result := 0 to count-1 do // all VName[]<>'' so n^<>0
if (PStrLen(n^-_STRLEN)^=len) and CompareMemFixed(pointer(n^),name,len) then
exit else
inc(n);
result := -1;
end;
function FindNonVoidRawUTF8I(n: PPtrInt; name: PUTF8Char; len: TStrLen; count: PtrInt): PtrInt;
begin
for result := 0 to count-1 do
if (PStrLen(n^-_STRLEN)^=len) and IdemPropNameUSameLen(pointer(n^),name,len) then
exit else
inc(n);
result := -1;
end;
function TDocVariantData.GetValueIndex(aName: PUTF8Char; aNameLen: PtrInt;
aCaseSensitive: boolean): integer;
var err: integer;
begin
if (integer(VType)=DocVariantVType) and (VCount>0) and (aName<>nil) and(aNameLen>0) then
if dvoIsArray in VOptions then begin // try index text in array document
result := GetInteger(aName,err);
if (err<>0) or (cardinal(result)>=cardinal(VCount)) then
result := -1;
end else
// O(n) lookup for object names -> efficient brute force sub-functions
if aCaseSensitive then
result := FindNonVoidRawUTF8(pointer(VName),aName,aNameLen,VCount) else
result := FindNonVoidRawUTF8I(pointer(VName),aName,aNameLen,VCount) else
result := -1;
end;
function TDocVariantData.GetValueOrRaiseException(const aName: RawUTF8): variant;
begin
RetrieveValueOrRaiseException(pointer(aName),length(aName),
dvoNameCaseSensitive in VOptions,result,false);
end;
function TDocVariantData.GetValueOrDefault(const aName: RawUTF8;
const aDefault: variant): variant;
var ndx: integer;
begin
if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) then
result := aDefault else begin
ndx := GetValueIndex(aName);
if ndx>=0 then
result := VValue[ndx] else
result := aDefault;
end;
end;
function TDocVariantData.GetValueOrNull(const aName: RawUTF8): variant;
var ndx: integer;
begin
if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) then
SetVariantNull(result) else begin
ndx := GetValueIndex(aName);
if ndx>=0 then
result := VValue[ndx] else
SetVariantNull(result);
end;
end;
function TDocVariantData.GetValueOrEmpty(const aName: RawUTF8): variant;
var ndx: integer;
begin
VarClear(result);
if (integer(VType)=DocVariantVType) and (dvoIsObject in VOptions) then begin
ndx := GetValueIndex(aName);
if ndx>=0 then
result := VValue[ndx];
end;
end;
function TDocVariantData.GetAsBoolean(const aName: RawUTF8; out aValue: boolean;
aSortedCompare: TUTF8Compare): Boolean;
var found: PVarData;
begin
found := GetVarData(aName,aSortedCompare);
if found=nil then
result := false else
result := VariantToBoolean(PVariant(found)^,aValue)
end;
function TDocVariantData.GetAsInteger(const aName: RawUTF8; out aValue: integer;
aSortedCompare: TUTF8Compare): Boolean;
var found: PVarData;
begin
found := GetVarData(aName,aSortedCompare);
if found=nil then
result := false else
result := VariantToInteger(PVariant(found)^,aValue);
end;
function TDocVariantData.GetAsInt64(const aName: RawUTF8; out aValue: Int64;
aSortedCompare: TUTF8Compare): Boolean;
var found: PVarData;
begin
found := GetVarData(aName,aSortedCompare);
if found=nil then
result := false else
result := VariantToInt64(PVariant(found)^,aValue)
end;
function TDocVariantData.GetAsDouble(const aName: RawUTF8; out aValue: double;
aSortedCompare: TUTF8Compare): Boolean;
var found: PVarData;
begin
found := GetVarData(aName,aSortedCompare);
if found=nil then
result := false else
result := VariantToDouble(PVariant(found)^,aValue);
end;
function TDocVariantData.GetAsRawUTF8(const aName: RawUTF8; out aValue: RawUTF8;
aSortedCompare: TUTF8Compare): Boolean;
var found: PVarData;
wasString: boolean;
begin
found := GetVarData(aName,aSortedCompare);
if found=nil then
result := false else begin
if integer(found^.VType)>varNull then // default VariantToUTF8(null)='null'
VariantToUTF8(PVariant(found)^,aValue,wasString);
result := true;
end;
end;
function TDocVariantData.GetValueEnumerate(const aName: RawUTF8;
aTypeInfo: pointer; out aValue; aDeleteFoundEntry: boolean): boolean;
var text: RawUTF8;
ndx, ord: integer;
begin
result := false;
ndx := GetValueIndex(aName);
if ndx<0 then
exit;
VariantToUTF8(Values[ndx],text);
ord := GetEnumNameValue(aTypeInfo,text,true);
if ord<0 then
exit;
byte(aValue) := ord;
if aDeleteFoundEntry then
Delete(ndx);
result := true;
end;
function TDocVariantData.GetAsDocVariant(const aName: RawUTF8; out aValue: PDocVariantData;
aSortedCompare: TUTF8Compare): boolean;
var found: PVarData;
begin
found := GetVarData(aName,aSortedCompare);
if found=nil then
result := false else begin
aValue := _Safe(PVariant(found)^);
result := aValue<>@DocVariantDataFake;
end;
end;
function TDocVariantData.GetAsDocVariantSafe(const aName: RawUTF8;
aSortedCompare: TUTF8Compare): PDocVariantData;
var found: PVarData;
begin
found := GetVarData(aName,aSortedCompare);
if found=nil then
result := @DocVariantDataFake else
result := _Safe(PVariant(found)^);
end;
function TDocVariantData.GetAsPVariant(const aName: RawUTF8; out aValue: PVariant;
aSortedCompare: TUTF8Compare): boolean;
begin
aValue := pointer(GetVarData(aName,aSortedCompare));
result := aValue<>nil;
end;
function TDocVariantData.GetAsPVariant(aName: PUTF8Char; aNameLen: PtrInt): PVariant;
var ndx: integer;
begin
ndx := GetValueIndex(aName,aNameLen,dvoNameCaseSensitive in VOptions);
if ndx>=0 then
result := @VValue[ndx] else
result := nil;
end;
function TDocVariantData.GetVarData(const aName: RawUTF8;
aSortedCompare: TUTF8Compare): PVarData;
var ndx: integer;
begin
if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) or
(VCount=0) or (aName='') then
result := nil else begin
if Assigned(aSortedCompare) then
if @aSortedCompare=@StrComp then // to use branchless asm for StrComp()
ndx := FastFindPUTF8CharSorted(pointer(VName),VCount-1,pointer(aName)) else
ndx := FastFindPUTF8CharSorted(pointer(VName),VCount-1,pointer(aName),aSortedCompare) else
if dvoNameCaseSensitive in VOptions then
ndx := FindNonVoidRawUTF8(pointer(VName),pointer(aName),length(aName),VCount) else
ndx := FindNonVoidRawUTF8I(pointer(VName),pointer(aName),length(aName),VCount);
if ndx>=0 then
result := @VValue[ndx] else
result := nil;
end;
end;
function TDocVariantData.GetVarData(const aName: RawUTF8;
var aValue: TVarData; aSortedCompare: TUTF8Compare): boolean;
var found: PVarData;
begin
found := GetVarData(aName,aSortedCompare);
if found=nil then
result := false else begin
aValue := found^;
result := true;
end;
end;
function TDocVariantData.GetValueByPath(const aPath: RawUTF8): variant;
var Dest: TVarData;
begin
VarClear(result);
if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) then
exit;
DocVariantType.Lookup(Dest,TVarData(self),pointer(aPath));
if integer(Dest.VType)>=varNull then
result := variant(Dest); // copy
end;
function TDocVariantData.GetValueByPath(const aPath: RawUTF8; out aValue: variant): boolean;
var Dest: TVarData;
begin
result := false;
if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) then
exit;
DocVariantType.Lookup(Dest,TVarData(self),pointer(aPath));
if Dest.VType=varEmpty then
exit;
aValue := variant(Dest); // copy
result := true;
end;
function TDocVariantData.GetPVariantByPath(const aPath: RawUTF8): PVariant;
var p: PUTF8Char;
item: RawUTF8;
par: PVariant;
begin
result := nil;
if (integer(VType)<>DocVariantVType) or (aPath='') or
not(dvoIsObject in VOptions) or (Count=0) then
exit;
par := @self;
P := pointer(aPath);
repeat
GetNextItem(P,'.',item);
if _Safe(par^).GetAsPVariant(item,result) then
par := result else begin
result := nil;
exit;
end;
until P=nil;
// if we reached here, we have par=result=found item
end;
function TDocVariantData.GetDocVariantByPath(const aPath: RawUTF8;
out aValue: PDocVariantData): boolean;
var v: PVariant;
begin
v := GetPVariantByPath(aPath);
if v<>nil then begin
aValue := _Safe(v^);
result := integer(aValue^.VType)>varNull;
end else
result := false;
end;
function TDocVariantData.GetValueByPath(const aDocVariantPath: array of RawUTF8): variant;
var found,res: PVarData;
vt,P: integer;
begin
VarClear(result);
if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) or
(high(aDocVariantPath)<0) then
exit;
found := @self;
P := 0;
repeat
found := PDocVariantData(found).GetVarData(aDocVariantPath[P]);
if found=nil then
exit;
if P=high(aDocVariantPath) then
break; // we found the item!
inc(P);
// if we reached here, we should try for the next scope within Dest
repeat
vt := found^.VType;
if vt<>varByRef or varVariant then
break;
found := found^.VPointer;
until false;
if vt=VType then
continue;
exit;
until false;
res := found;
while integer(res^.VType)=varByRef or varVariant do
res := res^.VPointer;
if (integer(res^.VType)=VType) and (PDocVariantData(res)^.VCount=0) then
// return void TDocVariant as null
TVarData(result).VType := varNull else
// copy found value
result := PVariant(found)^;
end;
function TDocVariantData.GetItemByProp(const aPropName,aPropValue: RawUTF8;
aPropValueCaseSensitive: boolean; var Dest: variant; DestByRef: boolean): boolean;
var ndx: integer;
begin
result := false;
if not(dvoIsArray in VOptions) then
exit;
ndx := SearchItemByProp(aPropName,aPropValue,aPropValueCaseSensitive);
if ndx<0 then
exit;
RetrieveValueOrRaiseException(ndx,Dest,DestByRef);
result := true;
end;
function TDocVariantData.GetDocVariantByProp(const aPropName,aPropValue: RawUTF8;
aPropValueCaseSensitive: boolean; out Dest: PDocVariantData): boolean;
var ndx: integer;
begin
result := false;
if not(dvoIsArray in VOptions) then
exit;
ndx := SearchItemByProp(aPropName,aPropValue,aPropValueCaseSensitive);
if ndx<0 then
exit;
Dest := _Safe(VValue[ndx]);
result := Dest^.VType>varNull;
end;
function TDocVariantData.GetJsonByStartName(const aStartName: RawUTF8): RawUTF8;
var Up: array[byte] of AnsiChar;
temp: TTextWriterStackBuffer;
ndx: integer;
W: TTextWriter;
begin
if not(dvoIsObject in VOptions) or (VCount=0) then begin
result := NULL_STR_VAR;
exit;
end;
UpperCopy255(Up,aStartName)^ := #0;
W := DefaultTextWriterSerializer.CreateOwnedStream(temp);
try
W.Add('{');
for ndx := 0 to VCount-1 do
if IdemPChar(Pointer(VName[ndx]),Up) then begin
if (dvoSerializeAsExtendedJson in VOptions) and
JsonPropNameValid(pointer(VName[ndx])) then begin
W.AddNoJSONEscape(pointer(VName[ndx]),Length(VName[ndx]));
end else begin
W.Add('"');
W.AddJSONEscape(pointer(VName[ndx]));
W.Add('"');
end;
W.Add(':');
W.AddVariant(VValue[ndx],twJSONEscape);
W.Add(',');
end;
W.CancelLastComma;
W.Add('}');
W.SetText(result);
finally
W.Free;
end;
end;
function TDocVariantData.GetValuesByStartName(const aStartName: RawUTF8;
TrimLeftStartName: boolean): variant;
var Up: array[byte] of AnsiChar;
ndx: integer;
name: RawUTF8;
begin
if aStartName='' then begin
result := Variant(self);
exit;
end;
if not(dvoIsObject in VOptions) or (VCount=0) then begin
SetVariantNull(result);
exit;
end;
TDocVariant.NewFast(result);
UpperCopy255(Up,aStartName)^ := #0;
for ndx := 0 to VCount-1 do
if IdemPChar(Pointer(VName[ndx]),Up) then begin
name := VName[ndx];
if TrimLeftStartName then
system.delete(name,1,length(aStartName));
TDocVariantData(result).AddValue(name,VValue[ndx]);
end;
end;
procedure TDocVariantData.SetValueOrRaiseException(Index: integer; const NewValue: variant);
begin
if cardinal(Index)>=cardinal(VCount) then
raise EDocVariant.CreateUTF8('Out of range Values[%] (count=%)',[Index,VCount]) else
VValue[Index] := NewValue;
end;
procedure TDocVariantData.RetrieveNameOrRaiseException(Index: integer;
var Dest: RawUTF8);
begin
if (cardinal(Index)>=cardinal(VCount)) or (VName=nil) then
if dvoReturnNullForUnknownProperty in VOptions then
Dest := '' else
raise EDocVariant.CreateUTF8('Out of range Names[%] (count=%)',[Index,VCount]) else
Dest := VName[Index];
end;
procedure TDocVariantData.RetrieveValueOrRaiseException(Index: integer;
var Dest: variant; DestByRef: boolean);
var Source: PVariant;
begin
if cardinal(Index)>=cardinal(VCount) then
if dvoReturnNullForUnknownProperty in VOptions then
SetVariantNull(Dest) else
raise EDocVariant.CreateUTF8('Out of range Values[%] (count=%)',[Index,VCount]) else
if DestByRef then
SetVariantByRef(VValue[Index],Dest) else begin
Source := @VValue[Index];
while PVarData(Source)^.VType=varVariant or varByRef do
Source := PVarData(Source)^.VPointer;
Dest := Source^;
end;
end;
function TDocVariantData.RetrieveValueOrRaiseException(
aName: PUTF8Char; aNameLen: integer; aCaseSensitive: boolean;
var Dest: variant; DestByRef: boolean): boolean;
var ndx: Integer;
begin
ndx := GetValueIndex(aName,aNameLen,aCaseSensitive);
if ndx<0 then
if dvoReturnNullForUnknownProperty in VOptions then
SetVariantNull(Dest) else
raise EDocVariant.CreateUTF8('[%] property not found',[aName]) else
RetrieveValueOrRaiseException(ndx,Dest,DestByRef);
result := ndx>=0;
end;
function TDocVariantData.GetValueOrItem(const aNameOrIndex: variant): variant;
var wasString: boolean;
Name: RawUTF8;
begin
if dvoIsArray in VOptions then // fast index lookup e.g. for Value[1]
RetrieveValueOrRaiseException(VariantToIntegerDef(aNameOrIndex,-1),result,true) else begin
VariantToUTF8(aNameOrIndex,Name,wasString); // by name lookup e.g. for Value['abc']
if wasString then
RetrieveValueOrRaiseException(pointer(Name),length(Name),
dvoNameCaseSensitive in VOptions,result,true) else
RetrieveValueOrRaiseException(GetIntegerDef(pointer(Name),-1),result,true);
end;
end;
procedure TDocVariantData.SetValueOrItem(const aNameOrIndex, aValue: variant);
var wasString: boolean;
ndx: integer;
Name: RawUTF8;
begin
if dvoIsArray in VOptions then // fast index lookup e.g. for Value[1]
SetValueOrRaiseException(VariantToIntegerDef(aNameOrIndex,-1),aValue) else begin
VariantToUTF8(aNameOrIndex,Name,wasString); // by name lookup e.g. for Value['abc']
if wasString then begin
ndx := GetValueIndex(Name);
if ndx<0 then
ndx := InternalAdd(Name);
SetVariantByValue(aValue,VValue[ndx]);
if dvoInternValues in VOptions then
DocVariantType.InternValues.UniqueVariant(VValue[ndx]);
end else
SetValueOrRaiseException(VariantToIntegerDef(aNameOrIndex,-1),aValue);
end;
end;
function TDocVariantData.AddOrUpdateValue(const aName: RawUTF8;
const aValue: variant; wasAdded: PBoolean; OnlyAddMissing: boolean): integer;
begin
if dvoIsArray in VOptions then
raise EDocVariant.CreateUTF8('AddOrUpdateValue("%") on an array',[aName]);
result := GetValueIndex(aName);
if result<0 then begin
result := InternalAdd(aName);
if wasAdded<>nil then
wasAdded^ := true;
end else begin
if wasAdded<>nil then
wasAdded^ := false;
if OnlyAddMissing then
exit;
end;
SetVariantByValue(aValue,VValue[result]);
if dvoInternValues in VOptions then
DocVariantType.InternValues.UniqueVariant(VValue[result]);
end;
function TDocVariantData.ToJSON(const Prefix, Suffix: RawUTF8;
Format: TTextWriterJSONFormat): RawUTF8;
var W: TTextWriter;
temp: TTextWriterStackBuffer;
begin
if (integer(VType)<>DocVariantVType) and (VType>varNull) then begin
result := ''; // null -> 'null'
exit;
end;
W := DefaultTextWriterSerializer.CreateOwnedStream(temp);
try
W.AddString(Prefix);
DocVariantType.ToJSON(W,variant(self),twJSONEscape);
W.AddString(Suffix);
W.SetText(result, Format);
finally
W.Free;
end;
end;
function TDocVariantData.ToNonExpandedJSON: RawUTF8;
var fields: TRawUTF8DynArray;
fieldsCount: integer;
W: TTextWriter;
r,f: integer;
row: PDocVariantData;
temp: TTextWriterStackBuffer;
begin
fields := nil; // to please Kylix
fieldsCount := 0;
if not(dvoIsArray in VOptions) then begin
result := '';
exit;
end;
if VCount=0 then begin
result := '[]';
exit;
end;
with _Safe(VValue[0])^ do
if dvoIsObject in VOptions then begin
fields := VName;
fieldsCount := VCount;
end;
if fieldsCount=0 then
raise EDocVariant.Create('ToNonExpandedJSON: Value[0] is not an object');
W := DefaultTextWriterSerializer.CreateOwnedStream(temp);
try
W.Add('{"fieldCount":%,"rowCount":%,"values":[',[fieldsCount,VCount]);
for f := 0 to fieldsCount-1 do begin
W.Add('"');
W.AddJSONEscape(pointer(fields[f]));
W.Add('"',',');
end;
for r := 0 to VCount-1 do begin
row := _Safe(VValue[r]);
if (r>0) and (not(dvoIsObject in row^.VOptions) or (row^.VCount<>fieldsCount)) then
raise EDocVariant.CreateUTF8('ToNonExpandedJSON: Value[%] not expected object',[r]);
for f := 0 to fieldsCount-1 do
if (r>0) and not IdemPropNameU(row^.VName[f],fields[f]) then
raise EDocVariant.CreateUTF8('ToNonExpandedJSON: Value[%] field=% expected=%',
[r,row^.VName[f],fields[f]]) else begin
W.AddVariant(row^.VValue[f],twJSONEscape);
W.Add(',');
end;
end;
W.CancelLastComma;
W.Add(']','}');
W.SetText(result);
finally
W.Free;
end;
end;
procedure TDocVariantData.ToRawUTF8DynArray(out Result: TRawUTF8DynArray);
var ndx: integer;
wasString: boolean;
begin
if dvoIsObject in VOptions then
raise EDocVariant.Create('ToRawUTF8DynArray expects a dvArray');
if dvoIsArray in VOptions then begin
SetLength(Result,VCount);
for ndx := 0 to VCount-1 do
VariantToUTF8(VValue[ndx],Result[ndx],wasString);
end;
end;
function TDocVariantData.ToRawUTF8DynArray: TRawUTF8DynArray;
begin
ToRawUTF8DynArray(result);
end;
function TDocVariantData.ToCSV(const Separator: RawUTF8): RawUTF8;
var tmp: TRawUTF8DynArray; // fast enough in practice
begin
ToRawUTF8DynArray(tmp);
result := RawUTF8ArrayToCSV(tmp,Separator);
end;
procedure TDocVariantData.ToTextPairsVar(out result: RawUTF8;
const NameValueSep, ItemSep: RawUTF8; escape: TTextWriterKind);
var ndx: integer;
temp: TTextWriterStackBuffer;
begin
if dvoIsArray in VOptions then
raise EDocVariant.Create('ToTextPairs expects a dvObject');
if (VCount>0) and (dvoIsObject in VOptions) then
with DefaultTextWriterSerializer.CreateOwnedStream(temp) do
try
ndx := 0;
repeat
AddString(VName[ndx]);
AddString(NameValueSep);
AddVariant(VValue[ndx],escape);
inc(ndx);
if ndx=VCount then
break;
AddString(ItemSep);
until false;
SetText(result);
finally
Free;
end;
end;
function TDocVariantData.ToTextPairs(const NameValueSep: RawUTF8;
const ItemSep: RawUTF8; Escape: TTextWriterKind): RawUTF8;
begin
ToTextPairsVar(result,NameValueSep,ItemSep,escape);
end;
procedure TDocVariantData.ToArrayOfConst(out Result: TTVarRecDynArray);
var ndx: integer;
begin
if dvoIsObject in VOptions then
raise EDocVariant.Create('ToArrayOfConst expects a dvArray');
if dvoIsArray in VOptions then begin
SetLength(Result,VCount);
for ndx := 0 to VCount-1 do begin
Result[ndx].VType := vtVariant;
Result[ndx].VVariant := @VValue[ndx];
end;
end;
end;
function TDocVariantData.ToArrayOfConst: TTVarRecDynArray;
begin
ToArrayOfConst(result);
end;
function TDocVariantData.ToUrlEncode(const UriRoot: RawUTF8): RawUTF8;
var json: RawUTF8; // temporary in-place modified buffer
begin
VariantSaveJSON(variant(self),twJSONEscape,json);
result := UrlEncodeJsonObject(UriRoot,Pointer(json),[]);
end;
function TDocVariantData.GetOrAddIndexByName(const aName: RawUTF8): integer;
begin
result := GetValueIndex(aName);
if result<0 then
result := InternalAdd(aName);
end;
function TDocVariantData.GetOrAddPVariantByName(const aName: RawUTF8): PVariant;
var ndx: integer;
begin
ndx := GetValueIndex(aName);
if ndx<0 then
ndx := InternalAdd(aName);
result := @VValue[ndx];
end;
function TDocVariantData.GetPVariantByName(const aName: RawUTF8): PVariant;
var ndx: Integer;
begin
ndx := GetValueIndex(aName);
if ndx<0 then
if dvoReturnNullForUnknownProperty in VOptions then
result := @DocVariantDataFake else
raise EDocVariant.CreateUTF8('[%] property not found',[aName]) else
result := @VValue[ndx];
end;
function TDocVariantData.GetInt64ByName(const aName: RawUTF8): Int64;
begin
if not VariantToInt64(GetPVariantByName(aName)^,result) then
result := 0;
end;
function TDocVariantData.GetRawUTF8ByName(const aName: RawUTF8): RawUTF8;
var wasString: boolean;
v: PVariant;
begin
v := GetPVariantByName(aName);
if PVarData(v)^.VType<=varNull then // default VariantToUTF8(null)='null'
result := '' else
VariantToUTF8(v^,result,wasString);
end;
function TDocVariantData.GetStringByName(const aName: RawUTF8): string;
begin
result := VariantToString(GetPVariantByName(aName)^);
end;
procedure TDocVariantData.SetInt64ByName(const aName: RawUTF8;
const aValue: Int64);
begin
GetOrAddPVariantByName(aName)^ := aValue;
end;
procedure TDocVariantData.SetRawUTF8ByName(const aName, aValue: RawUTF8);
begin
RawUTF8ToVariant(aValue,GetOrAddPVariantByName(aName)^);
end;
procedure TDocVariantData.SetStringByName(const aName: RawUTF8; const aValue: string);
begin
RawUTF8ToVariant(StringToUTF8(aValue),GetOrAddPVariantByName(aName)^);
end;
function TDocVariantData.GetBooleanByName(const aName: RawUTF8): Boolean;
begin
if not VariantToBoolean(GetPVariantByName(aName)^,result) then
result := false;
end;
procedure TDocVariantData.SetBooleanByName(const aName: RawUTF8; aValue: Boolean);
begin
GetOrAddPVariantByName(aName)^ := aValue;
end;
function TDocVariantData.GetDoubleByName(const aName: RawUTF8): Double;
begin
if not VariantToDouble(GetPVariantByName(aName)^,result) then
result := 0;
end;
procedure TDocVariantData.SetDoubleByName(const aName: RawUTF8;
const aValue: Double);
begin
GetOrAddPVariantByName(aName)^ := aValue;
end;
function TDocVariantData.GetDocVariantExistingByName(const aName: RawUTF8;
aNotMatchingKind: TDocVariantKind): PDocVariantData;
begin
result := GetAsDocVariantSafe(aName);
if result^.Kind=aNotMatchingKind then
result := @DocVariantDataFake;
end;
function TDocVariantData.GetDocVariantOrAddByName(const aName: RawUTF8;
aKind: TDocVariantKind): PDocVariantData;
var ndx: integer;
begin
ndx := GetOrAddIndexByName(aName);
result := _Safe(VValue[ndx]);
if result^.Kind<>aKind then begin
result := @VValue[ndx];
VarClear(PVariant(result)^);
result^.Init(JSON_OPTIONS_FAST,aKind);
end;
end;
function TDocVariantData.GetObjectExistingByName(const aName: RawUTF8): PDocVariantData;
begin
result := GetDocVariantExistingByName(aName,dvArray);
end;
function TDocVariantData.GetObjectOrAddByName(const aName: RawUTF8): PDocVariantData;
begin
result := GetDocVariantOrAddByName(aName,dvObject);
end;
function TDocVariantData.GetArrayExistingByName(const aName: RawUTF8): PDocVariantData;
begin
result := GetDocVariantExistingByName(aName,dvObject);
end;
function TDocVariantData.GetArrayOrAddByName(const aName: RawUTF8): PDocVariantData;
begin
result := GetDocVariantOrAddByName(aName,dvArray);
end;
function TDocVariantData.GetAsDocVariantByIndex(aIndex: integer): PDocVariantData;
begin
if cardinal(aIndex)<cardinal(VCount) then
result := _Safe(VValue[aIndex]) else
if dvoReturnNullForUnknownProperty in VOptions then
result := @DocVariantDataFake else
raise EDocVariant.CreateUTF8('Out of range _[%] (count=%)',[aIndex,VCount]);
end;
{ TDocVariant }
destructor TDocVariant.Destroy;
begin
inherited Destroy;
fInternNames.Free;
fInternValues.Free;
end;
function IntGetPseudoProp(ndx: integer; const source: TDocVariantData; var Dest: variant): boolean;
begin // sub-function to avoid temporary RawUTF8
result := true;
case ndx of
0: Dest := source.Count;
1: Dest := ord(source.Kind);
2: RawUTF8ToVariant(source.ToJSON,Dest);
else result := false;
end;
end;
function TDocVariant.IntGet(var Dest: TVarData; const Instance: TVarData;
Name: PAnsiChar; NameLen: PtrInt): boolean;
var dv: TDocVariantData absolute Instance;
begin
if Name=nil then
result := false else
if (NameLen>4) and (Name[0]='_') and
IntGetPseudoProp(IdemPCharArray(@Name[1],['COUNT','KIND','JSON']),dv,variant(Dest)) then
result := true else
result := dv.RetrieveValueOrRaiseException(pointer(Name),NameLen,
dvoNameCaseSensitive in dv.VOptions,PVariant(@Dest)^,{byref=}true);
end;
function TDocVariant.IntSet(const Instance, Value: TVarData;
Name: PAnsiChar; NameLen: PtrInt): boolean;
var ndx: Integer;
aName: RawUTF8;
dv: TDocVariantData absolute Instance;
begin
result := true;
if (dvoIsArray in dv.VOptions) and (PWord(Name)^=ord('_')) then begin
ndx := dv.InternalAdd('');
SetVariantByValue(variant(Value),dv.VValue[ndx]);
if dvoInternValues in dv.VOptions then
DocVariantType.InternValues.UniqueVariant(dv.VValue[ndx]);
exit;
end;
ndx := dv.GetValueIndex(pointer(Name),NameLen,dvoNameCaseSensitive in dv.VOptions);
if ndx<0 then begin
FastSetString(aName,Name,NameLen);
ndx := dv.InternalAdd(aName);
end;
SetVariantByValue(variant(Value),dv.VValue[ndx]);
if dvoInternValues in dv.VOptions then
DocVariantType.InternValues.UniqueVariant(dv.VValue[ndx]);
end;
function TDocVariant.IterateCount(const V: TVarData): integer;
var Data: TDocVariantData absolute V;
begin
if dvoIsArray in Data.VOptions then
result := Data.VCount else
result := -1;
end;
procedure TDocVariant.Iterate(var Dest: TVarData; const V: TVarData; Index: integer);
var Data: TDocVariantData absolute V;
begin
if (dvoIsArray in Data.VOptions) and (cardinal(Index)<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: PDocVariantData;
temp: RawUTF8;
procedure SetTempFromFirstArgument;
var wasString: boolean;
begin
VariantToUTF8(variant(Arguments[0]),temp,wasString);
end;
begin
result := true;
Data := @V; // Data=V is const so should not be modified - but we need it
case length(Arguments) of
{$ifndef FPC} // Data=@V trick raises GPF on FPC -> read/only
0: if SameText(Name,'Clear') then begin
Data^.VCount := 0;
Data^.VOptions := Data^.VOptions-[dvoIsObject,dvoIsArray];
exit;
end; {$endif FPC}
1: {$ifndef FPC} if SameText(Name,'Add') then begin
ndx := Data^.InternalAdd('');
SetVariantByValue(variant(Arguments[0]),Data^.VValue[ndx]);
if dvoInternValues in Data^.VOptions then
DocVariantType.InternValues.UniqueVariant(Data^.VValue[ndx]);
exit;
end else
if SameText(Name,'Delete') then begin
SetTempFromFirstArgument;
Data^.Delete(Data^.GetValueIndex(temp));
exit;
end else {$endif FPC}
if SameText(Name,'Exists') then begin
SetTempFromFirstArgument;
variant(Dest) := Data^.GetValueIndex(temp)>=0;
exit;
end else
if SameText(Name,'NameIndex') then begin
SetTempFromFirstArgument;
variant(Dest) := Data^.GetValueIndex(temp);
exit;
end else
if VariantToInteger(variant(Arguments[0]),ndx) then begin
if (Name='_') or SameText(Name,'Value') then begin
Data^.RetrieveValueOrRaiseException(ndx,variant(Dest),true);
exit;
end else
if SameText(Name,'Name') then begin
Data^.RetrieveNameOrRaiseException(ndx,temp);
RawUTF8ToVariant(temp,variant(Dest));
exit;
end;
end else
if (Name='_') or SameText(Name,'Value') then begin
SetTempFromFirstArgument;
Data^.RetrieveValueOrRaiseException(pointer(temp),length(temp),
dvoNameCaseSensitive in Data^.VOptions,variant(Dest),true);
exit;
end;
2:{$ifndef FPC} if SameText(Name,'Add') then begin
SetTempFromFirstArgument;
ndx := Data^.InternalAdd(temp);
SetVariantByValue(variant(Arguments[1]),Data^.VValue[ndx]);
if dvoInternValues in Data^.VOptions then
DocVariantType.InternValues.UniqueVariant(Data^.VValue[ndx]);
exit;
end; {$endif FPC}
end;
result := false;
end;
procedure TDocVariant.ToJSON(W: TTextWriter; const Value: variant;
escape: TTextWriterKind);
var ndx: integer;
vt: cardinal;
forced: TTextWriterOptions;
checkExtendedPropName: boolean;
begin
vt := TDocVariantData(Value).VType;
if vt>varNull then
if vt=cardinal(DocVariantVType) then
with TDocVariantData(Value) do
if [dvoIsArray,dvoIsObject]*VOptions=[] then
W.AddShort('null') else begin
if [twoForceJSONExtended,twoForceJSONStandard]*W.CustomOptions=[] then begin
if dvoSerializeAsExtendedJson in VOptions then
forced := [twoForceJSONExtended] else
forced := [twoForceJSONStandard];
W.CustomOptions := W.CustomOptions+forced;
end else
forced := [];
if dvoIsObject in VOptions then begin
checkExtendedPropName := twoForceJSONExtended in W.CustomOptions;
W.Add('{');
for ndx := 0 to VCount-1 do begin
if checkExtendedPropName and JsonPropNameValid(pointer(VName[ndx])) then begin
W.AddNoJSONEscape(pointer(VName[ndx]),Length(VName[ndx]));
end else begin
W.Add('"');
W.AddJSONEscape(pointer(VName[ndx]));
W.Add('"');
end;
W.Add(':');
W.AddVariant(VValue[ndx],twJSONEscape);
W.Add(',');
end;
W.CancelLastComma;
W.Add('}');
end else begin
W.Add('[');
for ndx := 0 to VCount-1 do begin
W.AddVariant(VValue[ndx],twJSONEscape);
W.Add(',');
end;
W.CancelLastComma;
W.Add(']');
end;
if forced<>[] then
W.CustomOptions := W.CustomOptions-forced;
end else
raise ESynException.CreateUTF8('Unexpected variant type %',[vt]) else
W.AddShort('null');
end;
procedure TDocVariant.Clear(var V: TVarData);
var dv: TDocVariantData absolute V;
begin
//Assert(V.VType=DocVariantVType);
RawUTF8DynArrayClear(dv.VName);
VariantDynArrayClear(dv.VValue);
ZeroFill(@V); // will set V.VType := varEmpty and VCount=0
end;
procedure TDocVariant.Copy(var Dest: TVarData; const Source: TVarData;
const Indirect: Boolean);
begin
//Assert(Source.VType=DocVariantVType);
if Indirect then
SimplisticCopy(Dest,Source,true) else
if dvoValueCopiedByReference in TDocVariantData(Source).Options then begin
VarClear(variant(Dest)); // Dest may be a complex type
pointer(TDocVariantData(Dest).VName) := nil; // avoid GPF
pointer(TDocVariantData(Dest).VValue) := nil;
TDocVariantData(Dest) := TDocVariantData(Source); // copy whole record
end else
CopyByValue(Dest,Source);
end;
procedure TDocVariant.CopyByValue(var Dest: TVarData; const Source: TVarData);
var S: TDocVariantData absolute Source;
D: TDocVariantData absolute Dest;
i: integer;
begin
//Assert(Source.VType=DocVariantVType);
VarClear(variant(Dest)); // Dest may be a complex type
D.VType := S.VType;
D.VOptions := S.VOptions; // copies also Kind
D.VCount := S.VCount;
pointer(D.VName) := nil; // avoid GPF
pointer(D.VValue) := nil;
if S.VCount=0 then
exit; // no data to copy
D.VName := S.VName; // names can always be safely copied
// slower but safe by-value copy
SetLength(D.VValue,S.VCount);
for i := 0 to S.VCount-1 do
D.VValue[i] := S.VValue[i];
end;
procedure TDocVariant.Cast(var Dest: TVarData; const Source: TVarData);
begin
CastTo(Dest,Source,VarType);
end;
procedure TDocVariant.CastTo(var Dest: TVarData;
const Source: TVarData; const AVarType: TVarType);
var Tmp: RawUTF8;
wasString: boolean;
begin
if AVarType=VarType then begin
VariantToUTF8(Variant(Source),Tmp,wasString);
if wasString then begin
VarClear(variant(Dest));
variant(Dest) := _JSONFast(Tmp); // convert from JSON text
exit;
end;
RaiseCastError;
end else begin
if Source.VType<>VarType then
RaiseCastError;
VariantSaveJSON(variant(Source),twJSONEscape,tmp);
RawUTF8ToVariant(Tmp,Dest,AVarType); // convert to JSON text
end;
end;
procedure TDocVariant.Compare(const Left, Right: TVarData;
var Relationship: TVarCompareResult);
var res: integer;
LeftU,RightU: RawUTF8;
begin
VariantSaveJSON(variant(Left),twJSONEscape,LeftU);
VariantSaveJSON(variant(Right),twJSONEscape,RightU);
if LeftU=RightU then
Relationship := crEqual else begin
res := StrComp(pointer(LeftU),pointer(RightU));
if res<0 then
Relationship := crLessThan else
if res>0 then
Relationship := crGreaterThan else
Relationship := crEqual;
end;
end;
class procedure TDocVariant.New(out aValue: variant;
aOptions: TDocVariantOptions);
begin
TDocVariantData(aValue).Init(aOptions);
end;
class procedure TDocVariant.NewFast(out aValue: variant);
begin
TDocVariantData(aValue).InitFast;
end;
class procedure TDocVariant.IsOfTypeOrNewFast(var aValue: variant);
begin
if DocVariantType.IsOfType(aValue) then
exit;
VarClear(aValue);
TDocVariantData(aValue).InitFast;
end;
class procedure TDocVariant.NewFast(const aValues: array of PDocVariantData);
var i: integer;
begin
for i := 0 to high(aValues) do
aValues[i]^.InitFast;
end;
class function TDocVariant.New(Options: TDocVariantOptions): Variant;
begin
VarClear(result);
TDocVariantData(result).Init(Options);
end;
class function TDocVariant.NewObject(const NameValuePairs: array of const;
Options: TDocVariantOptions): variant;
begin
VarClear(result);
TDocVariantData(result).InitObject(NameValuePairs,Options);
end;
class function TDocVariant.NewArray(const Items: array of const;
Options: TDocVariantOptions): variant;
begin
VarClear(result);
TDocVariantData(result).InitArray(Items,Options);
end;
class function TDocVariant.NewArray(const Items: TVariantDynArray;
Options: TDocVariantOptions): variant;
begin
VarClear(result);
TDocVariantData(result).InitArrayFromVariants(Items,Options);
end;
class function TDocVariant.NewJSON(const JSON: RawUTF8;
Options: TDocVariantOptions): variant;
begin
_Json(JSON,result,Options);
end;
class function TDocVariant.NewUnique(const SourceDocVariant: variant;
Options: TDocVariantOptions): variant;
begin
VarClear(result);
TDocVariantData(result).InitCopy(SourceDocVariant,Options);
end;
class procedure TDocVariant.GetSingleOrDefault(const docVariantArray, default: variant;
var result: variant);
var vt: integer;
begin
vt := TVarData(DocVariantArray).VType;
if vt=varByRef or varVariant then
GetSingleOrDefault(PVariant(TVarData(DocVariantArray).VPointer)^,default,result) else
if (vt<>DocVariantVType) or (TDocVariantData(DocVariantArray).Count<>1) or
not(dvoIsArray in TDocVariantData(DocVariantArray).VOptions) then
result := default else
result := TDocVariantData(DocVariantArray).Values[0];
end;
function ToText(kind: TDocVariantKind): PShortString;
begin
result := GetEnumName(TypeInfo(TDocVariantKind),ord(kind));
end;
function _Obj(const NameValuePairs: array of const;
Options: TDocVariantOptions): variant;
begin
VarClear(result);
TDocVariantData(result).InitObject(NameValuePairs,Options);
end;
function _Arr(const Items: array of const;
Options: TDocVariantOptions): variant;
begin
VarClear(result);
TDocVariantData(result).InitArray(Items,Options);
end;
procedure _ObjAddProps(const NameValuePairs: array of const; var Obj: variant);
var o: PDocVariantData;
begin
o := _Safe(Obj);
if not(dvoIsObject in o^.VOptions) then begin // create new object
VarClear(Obj);
TDocVariantData(Obj).InitObject(NameValuePairs,JSON_OPTIONS_FAST);
end else begin // append new names/values to existing object
TVarData(Obj) := PVarData(o)^; // ensure not stored by reference
o^.AddNameValuesToObject(NameValuePairs);
end;
end;
procedure _ObjAddProps(const Document: variant; var Obj: variant);
var ndx: integer;
d,o: PDocVariantData;
begin
d := _Safe(Document);
o := _Safe(Obj);
if dvoIsObject in d.VOptions then
if not(dvoIsObject in o.VOptions) then
Obj := Document else
for ndx := 0 to d^.VCount-1 do
o^.AddOrUpdateValue(d^.VName[ndx],d^.VValue[ndx]);
end;
function _ObjFast(const NameValuePairs: array of const): variant;
begin
VarClear(result);
TDocVariantData(result).InitObject(NameValuePairs,JSON_OPTIONS_FAST);
end;
function _ObjFast(aObject: TObject; aOptions: TTextWriterWriteObjectOptions): variant;
begin
VarClear(result);
if TDocVariantData(result).InitJSONInPlace(
pointer(ObjectToJson(aObject,aOptions)),JSON_OPTIONS_FAST)=nil then
VarClear(result);
end;
function _ArrFast(const Items: array of const): variant;
begin
VarClear(result);
TDocVariantData(result).InitArray(Items,JSON_OPTIONS_FAST);
end;
function _Json(const JSON: RawUTF8; Options: TDocVariantOptions): variant;
begin
_Json(JSON,result,Options);
end;
function _JsonFast(const JSON: RawUTF8): variant;
begin
_Json(JSON,result,JSON_OPTIONS_FAST);
end;
function _JsonFastFloat(const JSON: RawUTF8): variant;
begin
_Json(JSON,result,JSON_OPTIONS_FAST_FLOAT);
end;
function _JsonFastExt(const JSON: RawUTF8): variant;
begin
_Json(JSON,result,JSON_OPTIONS_FAST_EXTENDED);
end;
function _JsonFmt(const Format: RawUTF8; const Args,Params: array of const;
Options: TDocVariantOptions): variant;
begin
_JsonFmt(Format,Args,Params,Options,result);
end;
procedure _JsonFmt(const Format: RawUTF8; const Args,Params: array of const;
Options: TDocVariantOptions; out result: variant);
var temp: RawUTF8;
begin
temp := FormatUTF8(Format,Args,Params,true);
if TDocVariantData(result).InitJSONInPlace(pointer(temp),Options)=nil then
TDocVariantData(result).Clear;
end;
function _JsonFastFmt(const Format: RawUTF8; const Args,Params: array of const): variant;
begin
_JsonFmt(Format,Args,Params,JSON_OPTIONS_FAST,result);
end;
function _Json(const JSON: RawUTF8; var Value: variant;
Options: TDocVariantOptions): boolean;
begin
VarClear(Value);
if not TDocVariantData(Value).InitJSON(JSON,Options) then begin
VarClear(Value);
result := false;
end else
result := true;
end;
procedure _Unique(var DocVariant: variant);
begin // TDocVariantData(DocVariant): InitCopy() will check the DocVariant type
TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS[false]);
end;
procedure _UniqueFast(var DocVariant: variant);
begin // TDocVariantData(DocVariant): InitCopy() will check the DocVariant type
TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS_FAST);
end;
function _Copy(const DocVariant: variant): variant;
begin
result := TDocVariant.NewUnique(DocVariant,JSON_OPTIONS[false]);
end;
function _CopyFast(const DocVariant: variant): variant;
begin
result := TDocVariant.NewUnique(DocVariant,JSON_OPTIONS_FAST);
end;
function _ByRef(const DocVariant: variant; Options: TDocVariantOptions): variant;
begin
VarClear(result);
TDocVariantData(result) := _Safe(DocVariant)^; // fast byref copy
TDocVariantData(result).SetOptions(Options);
end;
procedure _ByRef(const DocVariant: variant; out Dest: variant;
Options: TDocVariantOptions);
begin
TDocVariantData(Dest) := _Safe(DocVariant)^; // fast byref copy
TDocVariantData(Dest).SetOptions(Options);
end;
function ObjectToVariant(Value: TObject; EnumSetsAsText: boolean): variant;
const OPTIONS: array[boolean] of TTextWriterWriteObjectOptions = (
[woDontStoreDefault],[woDontStoreDefault,woEnumSetsAsText]);
begin
VarClear(result);
ObjectToVariant(Value,result,OPTIONS[EnumSetsAsText]);
end;
procedure ObjectToVariant(Value: TObject; out Dest: variant);
begin
ObjectToVariant(Value,Dest,[woDontStoreDefault]);
end;
procedure ObjectToVariant(Value: TObject; var result: variant;
Options: TTextWriterWriteObjectOptions);
var json: RawUTF8;
begin
json := ObjectToJSON(Value,Options);
PDocVariantData(@result)^.InitJSONInPlace(pointer(json),JSON_OPTIONS_FAST);
end;
{$endif NOVARIANTS}
{ ****************** TDynArray wrapper }
{$ifndef DELPHI5OROLDER} // do not know why Delphi 5 compiler does not like CopyFrom()
procedure DynArrayCopy(var Dest; const Source; SourceMaxElem: integer;
TypeInfo: pointer);
var DestDynArray: TDynArray;
begin
DestDynArray.Init(TypeInfo,Dest);
DestDynArray.CopyFrom(Source,SourceMaxElem);
end;
{$endif DELPHI5OROLDER}
function DynArrayLoad(var Value; Source: PAnsiChar; TypeInfo: pointer): PAnsiChar;
var DynArray: TDynArray;
begin
DynArray.Init(TypeInfo,Value);
result := DynArray.LoadFrom(Source);
end;
function DynArraySave(var Value; TypeInfo: pointer): RawByteString;
var DynArray: TDynArray;
begin
DynArray.Init(TypeInfo,Value);
result := DynArray.SaveTo;
end;
function DynArrayLoadJSON(var Value; JSON: PUTF8Char; TypeInfo: pointer;
EndOfObject: PUTF8Char): PUTF8Char;
var DynArray: TDynArray;
begin
DynArray.Init(TypeInfo,Value);
result := DynArray.LoadFromJSON(JSON,EndOfObject);
end;
function DynArrayLoadJSON(var Value; const JSON: RawUTF8; TypeInfo: pointer): boolean;
var tmp: TSynTempBuffer;
begin
tmp.Init(JSON); // make private copy before in-place decoding
try
result := DynArrayLoadJSON(Value,tmp.buf,TypeInfo)<>nil;
finally
tmp.Done;
end;
end;
function DynArraySaveJSON(const Value; TypeInfo: pointer;
EnumSetsAsText: boolean): RawUTF8;
begin
result := SaveJSON(Value,TypeInfo,EnumSetsAsText);
end;
{$ifndef DELPHI5OROLDER}
function DynArrayEquals(TypeInfo: pointer; var Array1, Array2;
Array1Count, Array2Count: PInteger): boolean;
var DA1, DA2: TDynArray;
begin
DA1.Init(TypeInfo,Array1,Array1Count);
DA2.Init(TypeInfo,Array2,Array2Count);
result := DA1.Equals(DA2);
end;
{$endif DELPHI5OROLDER}
function DynArrayBlobSaveJSON(TypeInfo, BlobValue: pointer): RawUTF8;
var DynArray: TDynArray;
Value: pointer; // store the temporary dynamic array
temp: TTextWriterStackBuffer;
begin
Value := nil;
DynArray.Init(TypeInfo,Value);
try
if DynArray.LoadFrom(BlobValue)=nil then
result := '' else begin
with DefaultTextWriterSerializer.CreateOwnedStream(temp) do
try
AddDynArrayJSON(TypeInfo,Value);
SetText(result);
finally
Free;
end;
end;
finally
DynArray.SetCount(0);
end;
end;
function DynArrayElementTypeName(TypeInfo: pointer; ElemTypeInfo: PPointer;
ExactType: boolean): RawUTF8;
var DynArray: TDynArray;
VoidArray: pointer;
const KNOWNTYPE_ITEMNAME: array[TDynArrayKind] of RawUTF8 = ('',
'boolean','byte','word','integer','cardinal','single','Int64','QWord',
'double','currency','TTimeLog','TDateTime','TDateTimeMS',
'RawUTF8','WinAnsiString','string','RawByteString','WideString','SynUnicode',
'THash128','THash256','THash512','IInterface',{$ifndef NOVARIANTS}'variant',{$endif}'');
begin
VoidArray := nil;
DynArray.Init(TypeInfo,VoidArray);
result := '';
if ElemTypeInfo<>nil then
ElemTypeInfo^ := DynArray.ElemType;
if DynArray.ElemType<>nil then
TypeInfoToName(ElemTypeInfo,result) else
result := KNOWNTYPE_ITEMNAME[DynArray.GuessKnownType(ExactType)];
end;
procedure RawRecordDynArrayClear(v: PAnsiChar; info: PTypeInfo; n: integer);
var fields,f: PFieldInfo;
nfields,i: integer;
begin
info := GetTypeInfo(info);
nfields := GetManagedFields(info,fields); // inlined RecordClear()
if nfields>0 then
repeat
f := fields;
i := nfields;
repeat
{$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(v+f^.Offset,
{$ifdef HASDIRECTTYPEINFO}f^.TypeInfo{$else}PPointer(f^.TypeInfo)^{$endif});
inc(f);
dec(i);
until i=0;
inc(v,info^.recSize);
dec(n);
until n=0;
end;
procedure RawAnsiStringDynArrayClear(v: PPointer; n: PtrInt);
var p: PStrRec;
begin
repeat
p := v^;
if p<>nil then begin
v^ := nil;
dec(p);
if (p^.refCnt>=0) and StrCntDecFree(p^.refCnt) then
freemem(p);
end;
inc(v);
dec(n);
until n=0;
end;
procedure FastFinalizeArray(v: PPointer; ElemTypeInfo: pointer; n: integer);
begin // caller ensured ElemTypeInfo<>nil and n>0
case PTypeKind(ElemTypeInfo)^ of
tkRecord{$ifdef FPC},tkObject{$endif}:
RawRecordDynArrayClear(pointer(v),ElemTypeinfo,n);
{$ifndef NOVARIANTS}
tkVariant:
RawVariantDynArrayClear(pointer(v),n);
{$endif}
tkLString{$ifdef FPC},tkLStringOld{$endif}:
RawAnsiStringDynArrayClear(pointer(v),n);
tkWString:
repeat
if v^<>nil then
{$ifdef FPC}Finalize(WideString(v^)){$else}WideString(v^) := ''{$endif};
inc(v);
dec(n);
until n=0;
{$ifdef HASVARUSTRING}
tkUString:
repeat
if v^<>nil then
{$ifdef FPC}Finalize(UnicodeString(v^)){$else}UnicodeString(v^) := ''{$endif};
inc(v);
dec(n);
until n=0;
{$endif}
{$ifndef DELPHI5OROLDER}
tkInterface:
repeat
if v^<>nil then
{$ifdef FPC}Finalize(IInterface(v^)){$else}IInterface(v^) := nil{$endif};
inc(v);
dec(n);
until n=0;
{$endif}
tkDynArray: begin
ElemTypeInfo := Deref(GetTypeInfo(ElemTypeInfo)^.elType);
repeat
if v^<>nil then
FastDynArrayClear(v,ElemTypeInfo);
inc(v);
dec(n);
until n=0;
end;
else // fallback to regular finalization code for less common types
{$ifdef FPC}FPCFinalizeArray{$else}_FinalizeArray{$endif}(v,ElemTypeInfo,n);
end;
end;
procedure FastDynArrayClear(Value: PPointer; ElemTypeInfo: pointer);
var p: PDynArrayRec;
begin
if Value<>nil then begin
p := Value^;
if p<>nil then begin
dec(p);
if (p^.refCnt>=0) and DACntDecFree(p^.refCnt) then begin
if ElemTypeInfo<>nil then
FastFinalizeArray(Value^,ElemTypeInfo,p^.length);
Freemem(p);
end;
Value^ := nil;
end;
end;
end;
{$ifdef FPC_X64}
procedure _dynarray_decr_ref_free(p: PDynArrayRec; info: pointer);
begin
info := Deref(GetTypeInfo(info)^.elType);
if info <> nil then
FastFinalizeArray(pointer(PAnsiChar(p) + SizeOf(p^)), info, p^.length);
Freemem(p);
end;
{$endif FPC_X64}
function SortDynArrayBoolean(const A,B): integer;
begin
if boolean(A) then // normalize (seldom used, anyway)
if boolean(B) then
result := 0 else
result := 1 else
if boolean(B) then
result := -1 else
result := 0;
end;
function SortDynArrayByte(const A,B): integer;
begin
result := byte(A)-byte(B);
end;
function SortDynArraySmallint(const A,B): integer;
begin
result := smallint(A)-smallint(B);
end;
function SortDynArrayShortint(const A,B): integer;
begin
result := shortint(A)-shortint(B);
end;
function SortDynArrayWord(const A,B): integer;
begin
result := word(A)-word(B);
end;
function SortDynArrayPUTF8CharI(const A,B): integer;
begin
result := StrIComp(PUTF8Char(A),PUTF8Char(B));
end;
function SortDynArrayString(const A,B): integer;
begin
{$ifdef UNICODE}
result := StrCompW(PWideChar(A),PWideChar(B));
{$else}
result := StrComp(PUTF8Char(A),PUTF8Char(B));
{$endif}
end;
function SortDynArrayStringI(const A,B): integer;
begin
{$ifdef UNICODE}
result := AnsiICompW(PWideChar(A),PWideChar(B));
{$else}
result := StrIComp(PUTF8Char(A),PUTF8Char(B));
{$endif}
end;
function SortDynArrayFileName(const A,B): integer;
var Aname, Aext, Bname, Bext: TFileName;
begin // code below is not very fast, but is correct ;)
AName := GetFileNameWithoutExt(string(A),@Aext);
BName := GetFileNameWithoutExt(string(B),@Bext);
result := AnsiCompareFileName(Aext,Bext);
if result=0 then // if both extensions matches, compare by filename
result := AnsiCompareFileName(Aname,Bname);
end;
function SortDynArrayUnicodeString(const A,B): integer;
begin // works for tkWString and tkUString
result := StrCompW(PWideChar(A),PWideChar(B));
end;
function SortDynArrayUnicodeStringI(const A,B): integer;
begin
result := AnsiICompW(PWideChar(A),PWideChar(B));
end;
function SortDynArray128(const A,B): integer;
begin
if THash128Rec(A).Lo<THash128Rec(B).Lo then
result := -1 else
if THash128Rec(A).Lo>THash128Rec(B).Lo then
result := 1 else
if THash128Rec(A).Hi<THash128Rec(B).Hi then
result := -1 else
if THash128Rec(A).Hi>THash128Rec(B).Hi then
result := 1 else
result := 0;
end;
function SortDynArray256(const A,B): integer;
begin
result := SortDynArray128(THash256Rec(A).Lo,THash256Rec(B).Lo);
if result = 0 then
result := SortDynArray128(THash256Rec(A).Hi,THash256Rec(B).Hi);
end;
function SortDynArray512(const A,B): integer;
begin
result := SortDynArray128(THash512Rec(A).c0,THash512Rec(B).c0);
if result = 0 then begin
result := SortDynArray128(THash512Rec(A).c1,THash512Rec(B).c1);
if result = 0 then begin
result := SortDynArray128(THash512Rec(A).c2,THash512Rec(B).c2);
if result = 0 then
result := SortDynArray128(THash512Rec(A).c3,THash512Rec(B).c3);
end;
end;
end;
{$ifndef NOVARIANTS}
function VariantCompare(const V1,V2: variant): PtrInt;
begin
result := SortDynArrayVariantComp(TVarData(V1), TVarData(V2), false);
end;
function VariantCompareI(const V1,V2: variant): PtrInt;
begin
result := SortDynArrayVariantComp(TVarData(V1), TVarData(V2), true);
end;
function SortDynArrayVariantCompareAsString(const A,B: variant): integer;
var UA,UB: RawUTF8;
wasString: boolean;
begin
VariantToUTF8(A,UA,wasString);
VariantToUTF8(B,UB,wasString);
result := StrComp(pointer(UA),pointer(UB));
end;
function SortDynArrayVariantCompareAsStringI(const A,B: variant): integer;
var UA,UB: RawUTF8;
wasString: boolean;
begin
VariantToUTF8(A,UA,wasString);
VariantToUTF8(B,UB,wasString);
result := StrIComp(pointer(UA),pointer(UB));
end;
function SortDynArrayZero(const A,B): integer;
begin
result := 0;
end;
function SortDynArrayVariantComp(const A,B: TVarData; caseInsensitive: boolean): integer;
type
TSortDynArrayVariantComp = function(const A,B: variant): integer;
const
CMP: array[boolean] of TSortDynArrayVariantComp = (
SortDynArrayVariantCompareAsString,SortDynArrayVariantCompareAsStringI);
ICMP: array[TVariantRelationship] of integer = (0,-1,1,1);
SORT1: array[varEmpty..varDate] of TDynArraySortCompare = (
SortDynArrayZero, SortDynArrayZero, SortDynArraySmallInt, SortDynArrayInteger,
SortDynArraySingle, SortDynArrayDouble, SortDynArrayInt64, SortDynArrayDouble);
SORT2: array[varShortInt..varWord64] of TDynArraySortCompare = (
SortDynArrayShortInt, SortDynArrayByte, SortDynArrayWord, SortDynArrayCardinal,
SortDynArrayInt64, SortDynArrayQWord);
var AT,BT: integer;
begin
AT := integer(A.VType);
BT := integer(B.VType);
if AT=varVariant or varByRef then
result := SortDynArrayVariantComp(PVarData(A.VPointer)^,B,caseInsensitive) else
if BT=varVariant or varByRef then
result := SortDynArrayVariantComp(A,PVarData(B.VPointer)^,caseInsensitive) else
if AT=BT then
case AT of // optimized comparison if A and B share the same type
low(SORT1)..high(SORT1):
result := SORT1[AT](A.VAny,B.VAny);
low(SORT2)..high(SORT2):
result := SORT2[AT](A.VAny,B.VAny);
varString: // RawUTF8 most of the time (e.g. from TDocVariant)
if caseInsensitive then
result := StrIComp(A.VAny,B.VAny) else
result := StrComp(A.VAny,B.VAny);
varBoolean:
if A.VBoolean then // normalize
if B.VBoolean then
result := 0 else
result := 1 else
if B.VBoolean then
result := -1 else
result := 0;
varOleStr{$ifdef HASVARUSTRING},varUString{$endif}:
if caseInsensitive then
result := AnsiICompW(A.VAny,B.VAny) else
result := StrCompW(A.VAny,B.VAny);
else
if AT<varString then
result := ICMP[VarCompareValue(variant(A),variant(B))] else
result := CMP[caseInsensitive](variant(A),variant(B));
end else
if (AT<=varNull) or (BT<=varNull) then
result := ord(AT>varNull)-ord(BT>varNull) else
if (AT<varString) and (BT<varString) then
result := ICMP[VarCompareValue(variant(A),variant(B))] else
result := CMP[caseInsensitive](variant(A),variant(B));
end;
function SortDynArrayVariant(const A,B): integer;
begin
result := SortDynArrayVariantComp(TVarData(A),TVarData(B),false);
end;
function SortDynArrayVariantI(const A,B): integer;
begin
result := SortDynArrayVariantComp(TVarData(A),TVarData(B),true);
end;
{$endif NOVARIANTS}
{ TDynArray }
function TDynArray.GetCount: PtrInt;
begin
result := PtrUInt(fCountP);
if result<>0 then
result := PInteger(result)^ else begin
result := PtrUInt(fValue);
if result<>0 then begin
result := PPtrInt(result)^;
if result<>0 then
result := PDALen(result-_DALEN)^{$ifdef FPC}+1{$endif};
end;
end;
end;
procedure TDynArray.ElemCopy(const A; var B);
begin
if ElemType=nil then
MoveFast(A,B,ElemSize) else begin
{$ifdef FPC}
{$ifdef FPC_OLDRTTI}
FPCFinalize(@B,ElemType); // inlined CopyArray()
Move(A,B,ElemSize);
FPCRecordAddRef(B,ElemType);
{$else}
FPCRecordCopy(A,B,ElemType); // works for any kind of ElemTyp
{$endif FPC_OLDRTTI}
{$else}
CopyArray(@B,@A,ElemType,1);
{$endif FPC}
end;
end;
function TDynArray.Add(const Elem): PtrInt;
var p: PtrUInt;
begin
result := GetCount;
if fValue=nil then
exit; // avoid GPF if void
SetCount(result+1);
p := PtrUInt(fValue^)+PtrUInt(result)*ElemSize;
if ElemType=nil then
MoveFast(Elem,pointer(p)^,ElemSize) else
{$ifdef FPC}
FPCRecordCopy(Elem,pointer(p)^,ElemType);
{$else}
CopyArray(pointer(p),@Elem,ElemType,1);
{$endif}
end;
function TDynArray.New: integer;
begin
result := GetCount;
if fValue=nil then
exit; // avoid GPF if void
SetCount(result+1);
end;
function TDynArray.Peek(var Dest): boolean;
var index: PtrInt;
begin
index := GetCount-1;
result := index>=0;
if result then
ElemCopy(pointer(PtrUInt(fValue^)+PtrUInt(index)*ElemSize)^,Dest);
end;
function TDynArray.Pop(var Dest): boolean;
var index: integer;
begin
index := GetCount-1;
result := index>=0;
if result then begin
ElemMoveTo(index,Dest);
SetCount(index);
end;
end;
procedure TDynArray.Insert(Index: PtrInt; const Elem);
var n: PtrInt;
P: PByteArray;
begin
if fValue=nil then
exit; // avoid GPF if void
n := GetCount;
SetCount(n+1);
if PtrUInt(Index)<PtrUInt(n) then begin
P := pointer(PtrUInt(fValue^)+PtrUInt(Index)*ElemSize);
MoveFast(P[0],P[ElemSize],PtrUInt(n-Index)*ElemSize);
if ElemType<>nil then // avoid GPF in ElemCopy() below
FillCharFast(P^,ElemSize,0);
end else
// Index>=Count -> add at the end
P := pointer(PtrUInt(fValue^)+PtrUInt(n)*ElemSize);
ElemCopy(Elem,P^);
end;
procedure TDynArray.Clear;
begin
SetCount(0);
end;
function TDynArray.ClearSafe: boolean;
begin
try
SetCount(0);
result := true;
except // weak code, but may be a good idea in a destructor
result := false;
end;
end;
function TDynArray.GetIsObjArray: boolean;
begin
result := (fIsObjArray=oaTrue) or ((fIsObjArray=oaUnknown) and ComputeIsObjArray);
end;
function TDynArray.Delete(aIndex: PtrInt): boolean;
var n, len: PtrInt;
P: PAnsiChar;
begin
result := false;
if fValue=nil then
exit; // avoid GPF if void
n := GetCount;
if PtrUInt(aIndex)>=PtrUInt(n) then
exit; // out of range
if PDACnt(PtrUInt(fValue^)-_DAREFCNT)^>1 then
InternalSetLength(n,n); // unique
dec(n);
P := pointer(PtrUInt(fValue^)+PtrUInt(aIndex)*ElemSize);
if ElemType<>nil then
{$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(P,ElemType) else
if (fIsObjArray=oaTrue) or ((fIsObjArray=oaUnknown) and ComputeIsObjArray) then
FreeAndNil(PObject(P)^);
if n>aIndex then begin
len := PtrUInt(n-aIndex)*ElemSize;
MoveFast(P[ElemSize],P[0],len);
FillCharFast(P[len],ElemSize,0);
end else
FillCharFast(P^,ElemSize,0);
SetCount(n);
result := true;
end;
function TDynArray.ElemPtr(index: PtrInt): pointer;
label ok;
var c: PtrUInt;
begin // very efficient code on FPC and modern Delphi
result := pointer(fValue);
if result=nil then
exit;
result := PPointer(result)^;
if result=nil then
exit;
c := PtrUInt(fCountP);
if c<>0 then begin
if PtrUInt(index)<PCardinal(c)^ then
ok: inc(PByte(result),PtrUInt(index)*ElemSize) else
result := nil
end else
{$ifdef FPC}
if PtrUInt(index)<=PPtrUInt(PtrUInt(result)-_DALEN)^ then
{$else}
if PtrUInt(index)<PPtrUInt(PtrUInt(result)-_DALEN)^ then
{$endif FPC}
goto ok else
result := nil;
end;
procedure TDynArray.ElemCopyAt(index: PtrInt; var Dest);
var p: pointer;
begin
p := ElemPtr(index);
if p<>nil then
if ElemType=nil then
MoveFast(p^,Dest,ElemSize) else
{$ifdef FPC}
FPCRecordCopy(p^,Dest,ElemType); // works for any kind of ElemTyp
{$else}
CopyArray(@Dest,p,ElemType,1);
{$endif}
end;
procedure TDynArray.ElemMoveTo(index: PtrInt; var Dest);
var p: pointer;
begin
p := ElemPtr(index);
if (p=nil) or (@Dest=nil) then
exit;
ElemClear(Dest);
MoveFast(p^,Dest,ElemSize);
FillCharFast(p^,ElemSize,0); // ElemType=nil for ObjArray
end;
procedure TDynArray.ElemCopyFrom(const Source; index: PtrInt; ClearBeforeCopy: boolean);
var p: pointer;
begin
p := ElemPtr(index);
if p<>nil then
if ElemType=nil then
MoveFast(Source,p^,ElemSize) else begin
if ClearBeforeCopy then // safer if Source is a copy of p^
{$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(p,ElemType);
{$ifdef FPC}
FPCRecordCopy(Source,p^,ElemType);
{$else}
CopyArray(p,@Source,ElemType,1);
{$endif}
end;
end;
procedure TDynArray.Reverse;
var n, siz: PtrInt;
P1, P2: PAnsiChar;
c: AnsiChar;
i32: integer;
i64: Int64;
begin
n := GetCount-1;
if n>0 then begin
siz := ElemSize;
P1 := fValue^;
case siz of
1: begin // optimized version for TByteDynArray and such
P2 := P1+n;
while P1<P2 do begin
c := P1^;
P1^ := P2^;
P2^ := c;
inc(P1);
dec(P2);
end;
end;
4: begin // optimized version for TIntegerDynArray and such
P2 := P1+n*SizeOf(Integer);
while P1<P2 do begin
i32 := PInteger(P1)^;
PInteger(P1)^ := PInteger(P2)^;
PInteger(P2)^ := i32;
inc(P1,4);
dec(P2,4);
end;
end;
8: begin // optimized version for TInt64DynArray + TDoubleDynArray and such
P2 := P1+n*SizeOf(Int64);
while P1<P2 do begin
i64 := PInt64(P1)^;
PInt64(P1)^ := PInt64(P2)^;
PInt64(P2)^ := i64;
inc(P1,8);
dec(P2,8);
end;
end;
16: begin // optimized version for 32-bit TVariantDynArray and such
P2 := P1+n*16;
while P1<P2 do begin
{$ifdef CPU64}Exchg16{$else}ExchgVariant{$endif}(Pointer(P1),Pointer(P2));
inc(P1,16);
dec(P2,16);
end;
end;
{$ifdef CPU64}
24: begin // optimized version for 64-bit TVariantDynArray and such
P2 := P1+n*24;
while P1<P2 do begin
ExchgVariant(Pointer(P1),Pointer(P2));
inc(P1,24);
dec(P2,24);
end;
end;
{$endif CPU64}
else begin // generic version
P2 := P1+n*siz;
while P1<P2 do begin
Exchg(P1,P2,siz);
inc(P1,siz);
dec(P2,siz);
end;
end;
end;
end;
end;
procedure TDynArray.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
raise EStreamError.Create('TDynArray.SaveToStream: SaveTo');
MemStream.Seek(PosiEnd,soBeginning);
end else begin
tmp := SaveTo;
if Stream.Write(pointer(tmp)^,length(tmp))<>length(tmp) then
raise EStreamError.Create('TDynArray.SaveToStream: Write error');
end;
end;
procedure TDynArray.LoadFromStream(Stream: TCustomMemoryStream);
var P: PAnsiChar;
begin
P := PAnsiChar(Stream.Memory)+Stream.Seek(0,soCurrent);
Stream.Seek(LoadFrom(P,nil,false,PAnsiChar(Stream.Memory)+Stream.Size)-P,soCurrent);
end;
function TDynArray.SaveToTypeInfoHash(crc: cardinal): cardinal;
begin
if ElemType=nil then // hash fElemSize only if no pointer within
result := crc32c(crc,@fElemSize,4) else begin
result := crc;
ManagedTypeSaveRTTIHash(ElemType,result);
end;
end;
function TDynArray.SaveTo(Dest: PAnsiChar): PAnsiChar;
var i, n, LenBytes: integer;
P: PAnsiChar;
begin
if fValue=nil then begin
result := Dest;
exit; // avoid GPF if void
end;
// store the element size+type to check for the format (name='' mostly)
Dest := PAnsiChar(ToVarUInt32(ElemSize,pointer(Dest)));
if ElemType=nil then
Dest^ := #0 else
{$ifdef FPC}
Dest^ := AnsiChar(FPCTODELPHI[PTypeKind(ElemType)^]);
{$else}
Dest^ := PAnsiChar(ElemType)^;
{$endif}
inc(Dest);
// store dynamic array count
n := GetCount;
Dest := PAnsiChar(ToVarUInt32(n,pointer(Dest)));
if n=0 then begin
result := Dest;
exit;
end;
inc(Dest,SizeOf(Cardinal)); // leave space for Hash32 checksum
result := Dest;
// store dynamic array elements content
P := fValue^;
if ElemType=nil then // FPC: nil also if not Kind in tkManagedTypes
if GetIsObjArray then
raise ESynException.CreateUTF8('TDynArray.SaveTo(%) is a T*ObjArray',
[ArrayTypeShort^]) else begin
n := n*integer(ElemSize); // binary types: store as one
MoveFast(P^,Dest^,n);
inc(Dest,n);
end else
if PTypeKind(ElemType)^ in tkRecordTypes then
for i := 1 to n do begin
Dest := RecordSave(P^,Dest,ElemType,LenBytes);
inc(P,LenBytes);
end else
for i := 1 to n do begin
Dest := ManagedTypeSave(P,Dest,ElemType,LenBytes);
if Dest=nil then
break;
inc(P,LenBytes);
end;
// store Hash32 checksum
if Dest<>nil then // may be nil if RecordSave/ManagedTypeSave failed
PCardinal(result-SizeOf(Cardinal))^ := Hash32(pointer(result),Dest-result);
result := Dest;
end;
function TDynArray.SaveToLength: integer;
var i,n,L,size: integer;
P: PAnsiChar;
begin
if fValue=nil then begin
result := 0;
exit; // avoid GPF if void
end;
n := GetCount;
result := ToVarUInt32Length(ElemSize)+ToVarUInt32Length(n)+1;
if n=0 then
exit;
if ElemType=nil then // FPC: nil also if not Kind in tkManagedTypes
if GetIsObjArray then
raise ESynException.CreateUTF8('TDynArray.SaveToLength(%) is a T*ObjArray',
[ArrayTypeShort^]) else
inc(result,integer(ElemSize)*n) else begin
P := fValue^;
case PTypeKind(ElemType)^ of // inlined the most used kind of items
tkLString{$ifdef FPC},tkLStringOld{$endif}:
for i := 1 to n do begin
if PPtrUInt(P)^=0 then
inc(result) else
inc(result,ToVarUInt32LengthWithData(PStrLen(PPtrUInt(P)^-_STRLEN)^));
inc(P,SizeOf(pointer));
end;
tkRecord{$ifdef FPC},tkObject{$endif}:
for i := 1 to n do begin
inc(result,RecordSaveLength(P^,ElemType));
inc(P,ElemSize);
end;
else
for i := 1 to n do begin
L := ManagedTypeSaveLength(P,ElemType,size);
if L=0 then
break; // invalid record type (wrong field type)
inc(result,L);
inc(P,size);
end;
end;
end;
inc(result,SizeOf(Cardinal)); // Hash32 checksum
end;
function TDynArray.SaveTo: RawByteString;
var Len: integer;
begin
Len := SaveToLength;
SetString(result,nil,Len);
if Len<>0 then
if SaveTo(pointer(result))-pointer(result)<>Len then
raise ESynException.Create('TDynArray.SaveTo len concern');
end;
function TDynArray.SaveToJSON(EnumSetsAsText: boolean; reformat: TTextWriterJSONFormat): RawUTF8;
begin
SaveToJSON(result,EnumSetsAsText,reformat);
end;
procedure TDynArray.SaveToJSON(out Result: RawUTF8; EnumSetsAsText: boolean;
reformat: TTextWriterJSONFormat);
var temp: TTextWriterStackBuffer;
begin
with DefaultTextWriterSerializer.CreateOwnedStream(temp) do
try
if EnumSetsAsText then
CustomOptions := CustomOptions+[twoEnumSetsAsTextInRecord];
AddDynArrayJSON(self);
SetText(result,reformat);
finally
Free;
end;
end;
const
PTRSIZ = SizeOf(Pointer);
KNOWNTYPE_SIZE: array[TDynArrayKind] of byte = (
0, 1,1, 2, 4,4,4, 8,8,8,8,8,8,8, PTRSIZ,PTRSIZ,PTRSIZ,PTRSIZ,PTRSIZ,PTRSIZ,
16,32,64, PTRSIZ,
{$ifndef NOVARIANTS}SizeOf(Variant),{$endif} 0);
DYNARRAY_PARSERUNKNOWN = -2;
var // for TDynArray.LoadKnownType
KINDTYPE_INFO: array[TDynArrayKind] of pointer;
function TDynArray.GetArrayTypeName: RawUTF8;
begin
TypeInfoToName(fTypeInfo,result);
end;
function TDynArray.GetArrayTypeShort: PShortString;
begin // not inlined since PTypeInfo is private to implementation section
if fTypeInfo=nil then
result := @NULCHAR else
result := PShortString(@PTypeInfo(fTypeInfo).NameLen);
end;
function TDynArray.GuessKnownType(exactType: boolean): TDynArrayKind;
const
RTTI: array[TJSONCustomParserRTTIType] of TDynArrayKind = (
djNone, djBoolean, djByte, djCardinal, djCurrency, djDouble, djNone, djInt64,
djInteger, djQWord, djRawByteString, djNone, djRawUTF8, djNone, djSingle,
djString, djSynUnicode, djDateTime, djDateTimeMS, djHash128, djInt64, djTimeLog,
{$ifdef HASVARUSTRING} {$ifdef UNICODE}djSynUnicode{$else}djNone{$endif}, {$endif}
{$ifndef NOVARIANTS} djVariant, {$endif} djWideString, djWord, djNone);
var info: PTypeInfo;
field: PFieldInfo;
label bin, rec;
begin
result := fKnownType;
if result<>djNone then
exit;
info := fTypeInfo;
case ElemSize of // very fast guess of most known exact dynarray types
1: if info=TypeInfo(TBooleanDynArray) then
result := djBoolean;
4: if info=TypeInfo(TCardinalDynArray) then
result := djCardinal else
if info=TypeInfo(TSingleDynArray) then
result := djSingle
{$ifdef CPU64} ; 8: {$else} else {$endif}
if info=TypeInfo(TRawUTF8DynArray) then
result := djRawUTF8 else
if info=TypeInfo(TStringDynArray) then
result := djString else
if info=TypeInfo(TWinAnsiDynArray) then
result := djWinAnsi else
if info=TypeInfo(TRawByteStringDynArray) then
result := djRawByteString else
if info=TypeInfo(TSynUnicodeDynArray) then
result := djSynUnicode else
if (info=TypeInfo(TClassDynArray)) or
(info=TypeInfo(TPointerDynArray)) then
result := djPointer else
{$ifndef DELPHI5OROLDER}
if info=TypeInfo(TInterfaceDynArray) then
result := djInterface
{$endif DELPHI5OROLDER}
{$ifdef CPU64} else {$else} ; 8: {$endif}
if info=TypeInfo(TDoubleDynArray) then
result := djDouble else
if info=TypeInfo(TCurrencyDynArray) then
result := djCurrency else
if info=TypeInfo(TTimeLogDynArray) then
result := djTimeLog else
if info=TypeInfo(TDateTimeDynArray) then
result := djDateTime else
if info=TypeInfo(TDateTimeMSDynArray) then
result := djDateTimeMS;
end;
if result=djNone then begin // guess from RTTU
fKnownSize := 0;
if fElemType=nil then begin
{$ifdef DYNARRAYELEMTYPE2} // not backward compatible - disabled
if fElemType2<>nil then // try if a simple type known by extended RTTI
result := RTTI[TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(fElemType2)];
if result=djNone then
{$endif}
bin: case fElemSize of
1: result := djByte;
2: result := djWord;
4: result := djInteger;
8: result := djInt64;
16: result := djHash128;
32: result := djHash256;
64: result := djHash512;
else fKnownSize := fElemSize;
end;
end else // try to guess from 1st record/object field
if not exacttype and (PTypeKind(fElemType)^ in tkRecordTypes) then begin
info := fElemType; // inlined GetTypeInfo()
rec: {$ifdef HASALIGNTYPEDATA}
info := FPCTypeInfoOverName(info);
{$else}
inc(PByte(info),info^.NameLen);
{$endif}
{$ifdef FPC_OLDRTTI}
field := OldRTTIFirstManagedField(info);
if field=nil then
{$else}
if GetManagedFields(info,field)=0 then // only binary content
{$endif}
goto Bin;
case field^.Offset of
0: begin
info := DeRef(field^.TypeInfo);
if info=nil then // paranoid check
goto bin else
if info^.kind in tkRecordTypes then
goto rec; // nested records
result := RTTI[TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(info)];
if result=djNone then
goto Bin;
end;
1: result := djByte;
2: result := djWord;
4: result := djInteger;
8: result := djInt64;
16: result := djHash128;
32: result := djHash256;
64: result := djHash512;
else fKnownSize := field^.Offset;
end;
end else
// will recognize simple arrays from PTypeKind(fElemType)^
result := RTTI[TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(fElemType)];
end;
if KNOWNTYPE_SIZE[result]<>0 then
fKnownSize := KNOWNTYPE_SIZE[result];
fKnownType := result;
end;
function TDynArray.ElemCopyFirstField(Source,Dest: Pointer): boolean;
begin
if fKnownType=djNone then
GuessKnownType(false);
case fKnownType of
djBoolean..djDateTimeMS,djHash128..djHash512: // no managed field
MoveFast(Source^,Dest^,fKnownSize);
djRawUTF8, djWinAnsi, djRawByteString:
PRawByteString(Dest)^ := PRawByteString(Source)^;
djSynUnicode:
PSynUnicode(Dest)^ := PSynUnicode(Source)^;
djString:
PString(Dest)^ := PString(Source)^;
djWideString:
PWideString(Dest)^ := PWideString(Source)^;
{$ifndef NOVARIANTS}djVariant: PVariant(Dest)^ := PVariant(Source)^;{$endif}
else begin // djNone, djInterface, djCustom
result := false;
exit;
end;
end;
result := true;
end;
function TDynArray.LoadKnownType(Data,Source,SourceMax: PAnsiChar): boolean;
var info: PTypeInfo;
begin
if fKnownType=djNone then
GuessKnownType({exacttype=}false); // set fKnownType and fKnownSize
if fKnownType in [djBoolean..djDateTimeMS,djHash128..djHash512] then
if (SourceMax<>nil) and (Source+fKnownSize>SourceMax) then
result := false else begin
MoveFast(Source^,Data^,fKnownSize);
result := true;
end else begin
info := KINDTYPE_INFO[fKnownType];
if info=nil then
result := false else
result := (ManagedTypeLoad(Data,Source,info,SourceMax)<>0) and (Source<>nil);
end;
end;
const // kind of types which are serialized as JSON text
DJ_STRING = [djTimeLog..djHash512];
function TDynArray.LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char{$ifndef NOVARIANTS};
CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char;
var n, i, ValLen: integer;
T: TDynArrayKind;
wasString, expectedString, isValid: boolean;
EndOfObject: AnsiChar;
Val: PUTF8Char;
V: pointer;
CustomReader: TDynArrayJSONCustomReader;
NestedDynArray: TDynArray;
begin // code below must match TTextWriter.AddDynArrayJSON()
result := nil;
if (P=nil) or (fValue=nil) then
exit;
P := GotoNextNotSpace(P);
if P^<>'[' then begin
if (PInteger(P)^=NULL_LOW) and (jcEndOfJSONValueField in JSON_CHARS[P[4]]) then begin
SetCount(0);
result := P+4; // handle 'null' as void array
end;
exit;
end;
repeat inc(P) until not(P^ in [#1..' ']);
n := JSONArrayCount(P);
if n<0 then
exit; // invalid array content
if n=0 then begin
if NextNotSpaceCharIs(P,']') then begin
SetCount(0);
result := P;
end;
exit; // handle '[]' array
end;
{$ifndef NOVARIANTS}
if CustomVariantOptions=nil then
CustomVariantOptions := @JSON_OPTIONS[true];
{$endif}
if HasCustomJSONParser then
CustomReader := GlobalJSONCustomParsers.fParser[fParser].Reader else
CustomReader := nil;
if Assigned(CustomReader) then
T := djCustom else
T := GuessKnownType({exacttype=}true);
if (T=djNone) and (P^='[') and (PTypeKind(ElemType)^=tkDynArray) then begin
Count := n; // fast allocation of the whole dynamic array memory at once
for i := 0 to n-1 do begin
NestedDynArray.Init(ElemType,PPointerArray(fValue^)^[i]);
P := NestedDynArray.LoadFromJSON(P,@EndOfObject{$ifndef NOVARIANTS},
CustomVariantOptions{$endif});
if P=nil then
exit;
EndOfObject := P^; // ',' or ']' for the last item of the array
inc(P);
end;
end else
if (T=djNone) or
(PCardinal(P)^=JSON_BASE64_MAGIC_QUOTE) then begin
if n<>1 then
exit; // expect one Base64 encoded string value preceded by \uFFF0
Val := GetJSONField(P,P,@wasString,@EndOfObject,@ValLen);
if (Val=nil) or (ValLen<3) or not wasString or
(PInteger(Val)^ and $00ffffff<>JSON_BASE64_MAGIC) or
not LoadFromBinary(Base64ToBin(PAnsiChar(Val)+3,ValLen-3)) then
exit; // invalid content
end else begin
if GetIsObjArray then
for i := 0 to Count-1 do // force release any previous instance
FreeAndNil(PObjectArray(fValue^)^[i]);
SetCount(n); // fast allocation of the whole dynamic array memory at once
case T of
{$ifndef NOVARIANTS}
djVariant:
for i := 0 to n-1 do
P := VariantLoadJSON(PVariantArray(fValue^)^[i],P,@EndOfObject,CustomVariantOptions);
{$endif}
djCustom: begin
Val := fValue^;
for i := 1 to n do begin
P := CustomReader(P,Val^,isValid{$ifndef NOVARIANTS},CustomVariantOptions{$endif});
if not isValid then
exit;
EndOfObject := P^; // ',' or ']' for the last item of the array
inc(P);
inc(Val,ElemSize);
end;
end;
else begin
V := fValue^;
expectedString := T in DJ_STRING;
for i := 0 to n-1 do begin
Val := GetJSONField(P,P,@wasString,@EndOfObject,@ValLen);
if (Val=nil) or (wasString<>expectedString) then
exit;
case T of
djBoolean: PBooleanArray(V)^[i] := GetBoolean(Val);
djByte: PByteArray(V)^[i] := GetCardinal(Val);
djWord: PWordArray(V)^[i] := GetCardinal(Val);
djInteger: PIntegerArray(V)^[i] := GetInteger(Val);
djCardinal: PCardinalArray(V)^[i] := GetCardinal(Val);
djSingle: PSingleArray(V)^[i] := GetExtended(Val);
djInt64: SetInt64(Val,PInt64Array(V)^[i]);
djQWord: SetQWord(Val,PQWordArray(V)^[i]);
djTimeLog: PInt64Array(V)^[i] := Iso8601ToTimeLogPUTF8Char(Val,ValLen);
djDateTime, djDateTimeMS:
Iso8601ToDateTimePUTF8CharVar(Val,ValLen,PDateTimeArray(V)^[i]);
djDouble: PDoubleArray(V)^[i] := GetExtended(Val);
djCurrency: PInt64Array(V)^[i] := StrToCurr64(Val);
djRawUTF8: FastSetString(PRawUTF8Array(V)^[i],Val,ValLen);
djRawByteString:
if not Base64MagicCheckAndDecode(Val,ValLen,PRawByteStringArray(V)^[i]) then
FastSetString(PRawUTF8Array(V)^[i],Val,ValLen);
djWinAnsi: WinAnsiConvert.UTF8BufferToAnsi(Val,ValLen,PRawByteStringArray(V)^[i]);
djString: UTF8DecodeToString(Val,ValLen,string(PPointerArray(V)^[i]));
djWideString: UTF8ToWideString(Val,ValLen,WideString(PPointerArray(V)^[i]));
djSynUnicode: UTF8ToSynUnicode(Val,ValLen,SynUnicode(PPointerArray(V)^[i]));
djHash128: if ValLen<>SizeOf(THash128)*2 then FillZero(PHash128Array(V)^[i]) else
HexDisplayToBin(pointer(Val),@PHash128Array(V)^[i],SizeOf(THash128));
djHash256: if ValLen<>SizeOf(THash256)*2 then FillZero(PHash256Array(V)^[i]) else
HexDisplayToBin(pointer(Val),@PHash256Array(V)^[i],SizeOf(THash256));
djHash512: if ValLen<>SizeOf(THash512)*2 then FillZero(PHash512Array(V)^[i]) else
HexDisplayToBin(pointer(Val),@PHash512Array(V)^[i],SizeOf(THash512));
else raise ESynException.CreateUTF8('% not readable',[ToText(T)^]);
end;
end;
end;
end;
end;
if aEndOfObject<>nil then
aEndOfObject^ := EndOfObject;
if EndOfObject=']' then
if P=nil then
result := @NULCHAR else
result := P;
end;
{$ifndef NOVARIANTS}
function TDynArray.LoadFromVariant(const DocVariant: variant): boolean;
begin
with _Safe(DocVariant)^ do
if dvoIsArray in Options then
result := LoadFromJSON(pointer(_Safe(DocVariant)^.ToJSON))<>nil else
result := false;
end;
{$endif NOVARIANTS}
function TDynArray.LoadFromBinary(const Buffer: RawByteString;
NoCheckHash: boolean): boolean;
var P: PAnsiChar;
len: PtrInt;
begin
len := length(Buffer);
P := LoadFrom(pointer(Buffer),nil,NoCheckHash,PAnsiChar(pointer(Buffer))+len);
result := (P<>nil) and (P-pointer(Buffer)=len);
end;
function TDynArray.LoadFromHeader(var Source: PByte; SourceMax: PByte): integer;
var n: cardinal;
begin
// check context
result := -1; // to notify error
if (Source=nil) or (fValue=nil) then
exit;
// ignore legacy element size for cross-platform compatibility
if not FromVarUInt32(Source,SourceMax,n) or
((SourceMax<>nil) and (PAnsiChar(Source)>=PAnsiChar(SourceMax))) then
exit;
// check stored element type
if ElemType=nil then begin
if Source^<>0 then
exit;
end else
if Source^<>{$ifdef FPC}ord(FPCTODELPHI[PTypeKind(ElemType)^]){$else}
PByte(ElemType)^{$endif} then
exit;
inc(Source);
// retrieve dynamic array count
if FromVarUInt32(Source,SourceMax,n) then
if (n=0) or (SourceMax=nil) or
(PAnsiChar(Source)+SizeOf(cardinal)<PAnsiChar(SourceMax)) then
result := n;
end;
function TDynArray.LoadFrom(Source: PAnsiChar; AfterEach: TDynArrayAfterLoadFrom;
NoCheckHash: boolean; SourceMax: PAnsiChar): PAnsiChar;
var i, n: integer;
P: PAnsiChar;
Hash: PCardinalArray;
begin
// validate and unserialize binary header
result := nil;
SetCapacity(0); // clear current values, and reset growing factor
n := LoadFromHeader(PByte(Source),PByte(SourceMax));
if n<=0 then begin
if n=0 then
result := Source;
exit;
end;
SetCount(n);
// retrieve security checksum
Hash := pointer(Source);
inc(Source,SizeOf(cardinal));
// retrieve dynamic array elements content
P := fValue^;
if ElemType=nil then // FPC: nil also if not Kind in tkManagedTypes
if GetIsObjArray then
raise ESynException.CreateUTF8('TDynArray.LoadFrom: % is a T*ObjArray',
[ArrayTypeShort^]) else begin
// binary type was stored directly
n := n*integer(ElemSize);
if (SourceMax<>nil) and (Source+n>SourceMax) then exit;
MoveFast(Source^,P^,n);
inc(Source,n);
end else
if PTypeKind(ElemType)^ in tkRecordTypes then
for i := 1 to n do begin
Source := RecordLoad(P^,Source,ElemType,nil,SourceMax);
if Source=nil then exit;
if Assigned(AfterEach) then
AfterEach(P^);
inc(P,ElemSize);
end else
for i := 1 to n do begin
ManagedTypeLoad(P,Source,ElemType,SourceMax);
if Source=nil then exit;
if Assigned(AfterEach) then
AfterEach(P^);
inc(P,ElemSize);
end;
// check security checksum (Hash[0]=0 from mORMot2 DynArraySave)
if NoCheckHash or (Source=nil) or (Hash[0]=0) or
(Hash32(@Hash[1],Source-PAnsiChar(@Hash[1]))=Hash[0]) then
result := Source;
end;
function TDynArray.Find(const Elem; const aIndex: TIntegerDynArray;
aCompare: TDynArraySortCompare): PtrInt;
var n, L: PtrInt;
cmp: integer;
P: PAnsiChar;
begin
n := GetCount;
if (@aCompare<>nil) and (n>0) then begin
dec(n);
P := fValue^;
if (n>10) and (length(aIndex)>=n) then begin
// array should be sorted via aIndex[] -> use fast O(log(n)) binary search
L := 0;
repeat
result := (L+n) shr 1;
cmp := aCompare(P[cardinal(aIndex[result])*ElemSize],Elem);
if cmp=0 then begin
result := aIndex[result]; // returns index in TDynArray
exit;
end;
if cmp<0 then
L := result+1 else
n := result-1;
until L>n;
end else
// array is not sorted, or aIndex=nil -> use O(n) iterating search
for result := 0 to n do
if aCompare(P^,Elem)=0 then
exit else
inc(P,ElemSize);
end;
result := -1;
end;
function TDynArray.FindIndex(const Elem; aIndex: PIntegerDynArray;
aCompare: TDynArraySortCompare): PtrInt;
begin
if aIndex<>nil then
result := Find(Elem,aIndex^,aCompare) else
if Assigned(aCompare) then
result := Find(Elem,nil,aCompare) else
result := Find(Elem);
end;
function TDynArray.FindAndFill(var Elem; aIndex: PIntegerDynArray;
aCompare: TDynArraySortCompare): integer;
begin
result := FindIndex(Elem,aIndex,aCompare);
if result>=0 then // if found, fill Elem with the matching item
ElemCopy(PAnsiChar(fValue^)[cardinal(result)*ElemSize],Elem);
end;
function TDynArray.FindAndDelete(const Elem; aIndex: PIntegerDynArray;
aCompare: TDynArraySortCompare): integer;
begin
result := FindIndex(Elem,aIndex,aCompare);
if result>=0 then
Delete(result);
end;
function TDynArray.FindAndUpdate(const Elem; aIndex: PIntegerDynArray;
aCompare: TDynArraySortCompare): integer;
begin
result := FindIndex(Elem,aIndex,aCompare);
if result>=0 then // if found, fill Elem with the matching item
ElemCopy(Elem,PAnsiChar(fValue^)[cardinal(result)*ElemSize]);
end;
function TDynArray.FindAndAddIfNotExisting(const Elem; aIndex: PIntegerDynArray;
aCompare: TDynArraySortCompare): integer;
begin
result := FindIndex(Elem,aIndex,aCompare);
if result<0 then
Add(Elem); // -1 will mark success
end;
function TDynArray.Find(const Elem): PtrInt;
var n, L: PtrInt;
cmp: integer;
P: PAnsiChar;
begin
n := GetCount;
if (@fCompare<>nil) and (n>0) then begin
dec(n);
P := fValue^;
if fSorted and (n>10) then begin
// array is sorted -> use fast O(log(n)) binary search
L := 0;
repeat
result := (L+n) shr 1;
cmp := fCompare(P[cardinal(result)*ElemSize],Elem);
if cmp=0 then
exit;
if cmp<0 then
L := result+1 else
n := result-1;
until L>n;
end else // array is very small, or not sorted
for result := 0 to n do
if fCompare(P^,Elem)=0 then // O(n) search
exit else
inc(P,ElemSize);
end;
result := -1;
end;
function TDynArray.FindAllSorted(const Elem; out FirstIndex,LastIndex: Integer): boolean;
var found,last: integer;
P: PAnsiChar;
begin
result := FastLocateSorted(Elem,found);
if not result then
exit;
FirstIndex := found;
P := fValue^;
while (FirstIndex>0) and (fCompare(P[cardinal(FirstIndex-1)*ElemSize],Elem)=0) do
dec(FirstIndex);
last := GetCount-1;
LastIndex := found;
while (LastIndex<last) and (fCompare(P[cardinal(LastIndex+1)*ElemSize],Elem)=0) do
inc(LastIndex);
end;
function TDynArray.FastLocateSorted(const Elem; out Index: Integer): boolean;
var n, i, cmp: integer;
P: PAnsiChar;
begin
result := False;
n := GetCount;
if @fCompare<>nil then
if n=0 then // a void array is always sorted
Index := 0 else
if fSorted then begin
P := fValue^;
dec(n);
cmp := fCompare(Elem,P[cardinal(n)*ElemSize]);
if cmp>=0 then begin // greater than last sorted item
Index := n;
if cmp=0 then
result := true else // returns true + index of existing Elem
inc(Index); // returns false + insert after last position
exit;
end;
Index := 0;
while Index<=n do begin // O(log(n)) binary search of the sorted position
i := (Index+n) shr 1;
cmp := fCompare(P[cardinal(i)*ElemSize],Elem);
if cmp=0 then begin
Index := i; // returns true + index of existing Elem
result := True;
exit;
end else
if cmp<0 then
Index := i+1 else
n := i-1;
end;
// Elem not found: returns false + the index where to insert
end else
Index := -1 else // not Sorted
Index := -1; // no fCompare()
end;
procedure TDynArray.FastAddSorted(Index: Integer; const Elem);
begin
Insert(Index,Elem);
fSorted := true; // Insert -> SetCount -> fSorted := false
end;
procedure TDynArray.FastDeleteSorted(Index: Integer);
begin
Delete(Index);
fSorted := true; // Delete -> SetCount -> fSorted := false
end;
function TDynArray.FastLocateOrAddSorted(const Elem; wasAdded: PBoolean): integer;
var toInsert: boolean;
begin
toInsert := not FastLocateSorted(Elem,result) and (result>=0);
if toInsert then begin
Insert(result,Elem);
fSorted := true; // Insert -> SetCount -> fSorted := false
end;
if wasAdded<>nil then
wasAdded^ := toInsert;
end;
type
// internal structure used to make QuickSort faster & with less stack usage
TDynArrayQuickSort = object
Compare: TDynArraySortCompare;
CompareEvent: TEventDynArraySortCompare;
Pivot: pointer;
Index: PCardinalArray;
ElemSize: cardinal;
P: PtrInt;
Value: PAnsiChar;
IP, JP: PAnsiChar;
procedure QuickSort(L, R: PtrInt);
procedure QuickSortIndexed(L, R: PtrInt);
procedure QuickSortEvent(L, R: PtrInt);
procedure QuickSortEventReverse(L, R: PtrInt);
end;
procedure QuickSortIndexedPUTF8Char(Values: PPUtf8CharArray; Count: Integer;
var SortedIndexes: TCardinalDynArray; CaseSensitive: boolean);
var QS: TDynArrayQuickSort;
begin
if CaseSensitive then
QS.Compare := SortDynArrayPUTF8Char else
QS.Compare := SortDynArrayPUTF8CharI;
QS.Value := pointer(Values);
QS.ElemSize := SizeOf(PUTF8Char);
SetLength(SortedIndexes,Count);
FillIncreasing(pointer(SortedIndexes),0,Count);
QS.Index := pointer(SortedIndexes);
QS.QuickSortIndexed(0,Count-1);
end;
procedure DynArraySortIndexed(Values: pointer; ElemSize, Count: Integer;
out Indexes: TSynTempBuffer; Compare: TDynArraySortCompare);
var QS: TDynArrayQuickSort;
begin
QS.Compare := Compare;
QS.Value := Values;
QS.ElemSize := ElemSize;
QS.Index := pointer(Indexes.InitIncreasing(Count));
QS.QuickSortIndexed(0,Count-1);
end;
procedure TDynArrayQuickSort.QuickSort(L, R: PtrInt);
var I, J: PtrInt;
{$ifndef PUREPASCAL}tmp: pointer;{$endif}
begin
if L<R then
repeat
I := L; J := R;
P := (L + R) shr 1;
repeat
Pivot := Value+PtrUInt(P)*ElemSize;
IP := Value+PtrUInt(I)*ElemSize;
JP := Value+PtrUInt(J)*ElemSize;
while Compare(IP^,Pivot^)<0 do begin
inc(I);
inc(IP,ElemSize);
end;
while Compare(JP^,Pivot^)>0 do begin
dec(J);
dec(JP,ElemSize);
end;
if I <= J then begin
if I<>J then
{$ifndef PUREPASCAL} // inlined Exchg() is just fine
if ElemSize=SizeOf(pointer) then begin
// optimized version e.g. for TRawUTF8DynArray/TObjectDynArray
tmp := PPointer(IP)^;
PPointer(IP)^ := PPointer(JP)^;
PPointer(JP)^ := tmp;
end else
{$endif}
// generic exchange of row element data
Exchg(IP,JP,ElemSize);
if P = I then P := J else
if P = J then P := I;
Inc(I); Dec(J);
end;
until I > J;
if J - L < R - I then begin // use recursion only for smaller range
if L < J then
QuickSort(L, J);
L := I;
end else begin
if I < R then
QuickSort(I, R);
R := J;
end;
until L >= R;
end;
procedure TDynArrayQuickSort.QuickSortEvent(L, R: PtrInt);
var I, J: PtrInt;
begin
if L<R then
repeat
I := L; J := R;
P := (L + R) shr 1;
repeat
Pivot := Value+PtrUInt(P)*ElemSize;
IP := Value+PtrUInt(I)*ElemSize;
JP := Value+PtrUInt(J)*ElemSize;
while CompareEvent(IP^,Pivot^)<0 do begin
inc(I);
inc(IP,ElemSize);
end;
while CompareEvent(JP^,Pivot^)>0 do begin
dec(J);
dec(JP,ElemSize);
end;
if I <= J then begin
if I<>J then
Exchg(IP,JP,ElemSize);
if P = I then P := J else
if P = J then P := I;
Inc(I); Dec(J);
end;
until I > J;
if J - L < R - I then begin // use recursion only for smaller range
if L < J then
QuickSortEvent(L, J);
L := I;
end else begin
if I < R then
QuickSortEvent(I, R);
R := J;
end;
until L >= R;
end;
procedure TDynArrayQuickSort.QuickSortEventReverse(L, R: PtrInt);
var I, J: PtrInt;
begin
if L<R then
repeat
I := L; J := R;
P := (L + R) shr 1;
repeat
Pivot := Value+PtrUInt(P)*ElemSize;
IP := Value+PtrUInt(I)*ElemSize;
JP := Value+PtrUInt(J)*ElemSize;
while CompareEvent(IP^,Pivot^)>0 do begin
inc(I);
inc(IP,ElemSize);
end;
while CompareEvent(JP^,Pivot^)<0 do begin
dec(J);
dec(JP,ElemSize);
end;
if I <= J then begin
if I<>J then
Exchg(IP,JP,ElemSize);
if P = I then P := J else
if P = J then P := I;
Inc(I); Dec(J);
end;
until I > J;
if J - L < R - I then begin // use recursion only for smaller range
if L < J then
QuickSortEventReverse(L, J);
L := I;
end else begin
if I < R then
QuickSortEventReverse(I, R);
R := J;
end;
until L >= R;
end;
procedure TDynArrayQuickSort.QuickSortIndexed(L, R: PtrInt);
var I, J: PtrInt;
tmp: integer;
begin
if L<R then
repeat
I := L; J := R;
P := (L + R) shr 1;
repeat
Pivot := Value+Index[P]*ElemSize;
while Compare(Value[Index[I]*ElemSize],Pivot^)<0 do inc(I);
while Compare(Value[Index[J]*ElemSize],Pivot^)>0 do dec(J);
if I <= J then begin
if I<>J then begin
tmp := Index[I];
Index[I] := Index[J];
Index[J] := tmp;
end;
if P = I then P := J else
if P = J then P := I;
Inc(I); Dec(J);
end;
until I > J;
if J - L < R - I then begin // use recursion only for smaller range
if L < J then
QuickSortIndexed(L, J);
L := I;
end else begin
if I < R then
QuickSortIndexed(I, R);
R := J;
end;
until L >= R;
end;
procedure TDynArray.Sort(aCompare: TDynArraySortCompare);
begin
SortRange(0,Count-1,aCompare);
fSorted := true;
end;
procedure QuickSortPtr(L, R: PtrInt; Compare: TDynArraySortCompare; V: PPointerArray);
var I, J, P: PtrInt;
tmp: pointer;
begin
if L<R then
repeat
I := L; J := R;
P := (L + R) shr 1;
repeat
while Compare(V[I], V[P])<0 do
inc(I);
while Compare(V[J], V[P])>0 do
dec(J);
if I <= J then begin
tmp := V[I];
V[I] := V[J];
V[J] := tmp;
if P = I then P := J else
if P = J then P := I;
Inc(I); Dec(J);
end;
until I > J;
if J - L < R - I then begin // use recursion only for smaller range
if L < J then
QuickSortPtr(L, J, Compare, V);
L := I;
end else begin
if I < R then
QuickSortPtr(I, R, Compare, V);
R := J;
end;
until L >= R;
end;
procedure TDynArray.SortRange(aStart, aStop: integer; aCompare: TDynArraySortCompare);
var QuickSort: TDynArrayQuickSort;
begin
if aStop<=aStart then
exit; // nothing to sort
if @aCompare=nil then
Quicksort.Compare := @fCompare else
Quicksort.Compare := aCompare;
if (@Quicksort.Compare<>nil) and (fValue<>nil) and (fValue^<>nil) then
if ElemSize=SizeOf(pointer) then
QuickSortPtr(aStart,aStop,QuickSort.Compare,fValue^) else begin
Quicksort.Value := fValue^;
Quicksort.ElemSize := ElemSize;
Quicksort.QuickSort(aStart,aStop);
end;
end;
procedure TDynArray.Sort(const aCompare: TEventDynArraySortCompare; aReverse: boolean);
var QuickSort: TDynArrayQuickSort;
R: PtrInt;
begin
if not Assigned(aCompare) or (fValue = nil) or (fValue^=nil) then
exit; // nothing to sort
Quicksort.CompareEvent := aCompare;
Quicksort.Value := fValue^;
Quicksort.ElemSize := ElemSize;
R := Count-1;
if aReverse then
Quicksort.QuickSortEventReverse(0,R) else
Quicksort.QuickSortEvent(0,R);
end;
procedure TDynArray.CreateOrderedIndex(var aIndex: TIntegerDynArray;
aCompare: TDynArraySortCompare);
var QuickSort: TDynArrayQuickSort;
n: integer;
begin
if @aCompare=nil then
Quicksort.Compare := @fCompare else
Quicksort.Compare := aCompare;
if (@QuickSort.Compare<>nil) and (fValue<>nil) and (fValue^<>nil) then begin
n := GetCount;
if length(aIndex)<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;
procedure TDynArray.CreateOrderedIndex(out aIndex: TSynTempBuffer;
aCompare: TDynArraySortCompare);
var QuickSort: TDynArrayQuickSort;
n: integer;
begin
if @aCompare=nil then
Quicksort.Compare := @fCompare else
Quicksort.Compare := aCompare;
if (@QuickSort.Compare<>nil) and (fValue<>nil) and (fValue^<>nil) then begin
n := GetCount;
Quicksort.Value := fValue^;
Quicksort.ElemSize := ElemSize;
Quicksort.Index := PCardinalArray(aIndex.InitIncreasing(n));
Quicksort.QuickSortIndexed(0,n-1);
end else
aIndex.buf := nil; // avoid GPF in aIndex.Done
end;
procedure TDynArray.CreateOrderedIndexAfterAdd(var aIndex: TIntegerDynArray;
aCompare: TDynArraySortCompare);
var ndx: integer;
begin
ndx := GetCount-1;
if ndx<0 then
exit;
if aIndex<>nil then begin // whole FillIncreasing(aIndex[]) for first time
if ndx>=length(aIndex) then
SetLength(aIndex,NextGrow(ndx)); // grow aIndex[] if needed
aIndex[ndx] := ndx;
end;
CreateOrderedIndex(aIndex,aCompare);
end;
function TDynArray.ElemEquals(const A,B): boolean;
begin
if @fCompare<>nil then
result := fCompare(A,B)=0 else
if ElemType=nil then
case ElemSize of // optimized versions for arrays of common types
1: result := byte(A)=byte(B);
2: result := word(A)=word(B);
4: result := cardinal(A)=cardinal(B);
8: result := Int64(A)=Int64(B);
16: result := IsEqual(THash128(A),THash128(B));
else result := CompareMemFixed(@A,@B,ElemSize); // binary comparison
end else
if PTypeKind(ElemType)^ in tkRecordTypes then // most likely
result := RecordEquals(A,B,ElemType) else
result := ManagedTypeCompare(@A,@B,ElemType)>0; // other complex types
end;
{$ifndef DELPHI5OROLDER} // disabled for Delphi 5 buggy compiler
procedure TDynArray.InitFrom(const aAnother: TDynArray; var aValue);
begin
self := aAnother;
fValue := @aValue;
fCountP := nil;
end;
procedure TDynArray.AddDynArray(const aSource: TDynArray; aStartIndex: integer;
aCount: integer);
var SourceCount: integer;
begin
if (aSource.fValue<>nil) and (ArrayType=aSource.ArrayType) then begin
SourceCount := aSource.Count;
if (aCount<0) or (aCount>SourceCount) then
aCount := SourceCount; // force use of external Source.Count, if any
AddArray(aSource.fValue^,aStartIndex,aCount);
end;
end;
function TDynArray.Equals(const B: TDynArray; ignorecompare: boolean): boolean;
var i, n: integer;
P1,P2: PAnsiChar;
A1: PPointerArray absolute P1;
A2: PPointerArray absolute P2;
function HandleObjArray: boolean;
var tmp1,tmp2: RawUTF8;
begin
SaveToJSON(tmp1);
B.SaveToJSON(tmp2);
result := tmp1=tmp2;
end;
begin
result := false;
if ArrayType<>B.ArrayType then
exit; // array types should match exactly
n := GetCount;
if n<>B.Count then
exit;
if GetIsObjArray then begin
result := HandleObjArray;
exit;
end;
P1 := fValue^;
P2 := B.fValue^;
if (@fCompare<>nil) and not ignorecompare then // use customized comparison
for i := 1 to n do
if fCompare(P1^,P2^)<>0 then
exit else begin
inc(P1,ElemSize);
inc(P2,ElemSize);
end else
if ElemType=nil then begin // binary type is compared as a whole
result := CompareMem(P1,P2,ElemSize*cardinal(n));
exit;
end else
case PTypeKind(ElemType)^ of // some optimized versions for most used types
tkLString{$ifdef FPC},tkLStringOld{$endif}:
for i := 0 to n-1 do
if AnsiString(A1^[i])<>AnsiString(A2^[i]) then
exit;
tkWString:
for i := 0 to n-1 do
if WideString(A1^[i])<>WideString(A2^[i]) then
exit;
{$ifdef HASVARUSTRING}
tkUString:
for i := 0 to n-1 do
if UnicodeString(A1^[i])<>UnicodeString(A2^[i]) then
exit;
{$endif}
tkRecord{$ifdef FPC},tkObject{$endif}:
for i := 1 to n do
if not RecordEquals(P1^,P2^,ElemType) then
exit else begin
inc(P1,ElemSize);
inc(P2,ElemSize);
end;
else // generic TypeInfoCompare() use
for i := 1 to n do
if ManagedTypeCompare(P1,P2,ElemType)<=0 then
exit else begin // A^<>B^ or unexpected type
inc(P1,ElemSize);
inc(P2,ElemSize);
end;
end;
result := true;
end;
procedure TDynArray.Copy(const Source: TDynArray; ObjArrayByRef: boolean);
var n: Cardinal;
begin
if (fValue=nil) or (ArrayType<>Source.ArrayType) then
exit;
if (fCountP<>nil) and (Source.fCountP<>nil) then
SetCapacity(Source.GetCapacity);
n := Source.Count;
SetCount(n);
if n<>0 then
if ElemType=nil then
if not ObjArrayByRef and GetIsObjArray then
LoadFromJSON(pointer(Source.SaveToJSON)) else
MoveFast(Source.fValue^^,fValue^^,n*ElemSize) else
CopyArray(fValue^,Source.fValue^,ElemType,n);
end;
procedure TDynArray.CopyFrom(const Source; MaxElem: integer; ObjArrayByRef: boolean);
var SourceDynArray: TDynArray;
begin
SourceDynArray.Init(fTypeInfo,pointer(@Source)^);
SourceDynArray.fCountP := @MaxElem; // would set Count=0 at Init()
Copy(SourceDynArray,ObjArrayByRef);
end;
procedure TDynArray.CopyTo(out Dest; ObjArrayByRef: boolean);
var DestDynArray: TDynArray;
begin
DestDynArray.Init(fTypeInfo,Dest);
DestDynArray.Copy(self,ObjArrayByRef);
end;
{$endif DELPHI5OROLDER}
function TDynArray.IndexOf(const Elem): PtrInt;
var P: PPointerArray;
max: PtrInt;
begin
if fValue<>nil then begin
max := GetCount-1;
P := fValue^;
if @Elem<>nil then
if ElemType=nil then begin
result := AnyScanIndex(P,@Elem,max+1,ElemSize);
exit;
end else
case PTypeKind(ElemType)^ of
tkLString{$ifdef FPC},tkLStringOld{$endif}:
for result := 0 to max do
if AnsiString(P^[result])=AnsiString(Elem) then exit;
tkWString:
for result := 0 to max do
if WideString(P^[result])=WideString(Elem) then exit;
{$ifdef HASVARUSTRING}
tkUString:
for result := 0 to max do
if UnicodeString(P^[result])=UnicodeString(Elem) then exit;
{$endif}
{$ifndef NOVARIANTS}
tkVariant:
for result := 0 to max do
if SortDynArrayVariantComp(PVarDataStaticArray(P)^[result],
TVarData(Elem),false)=0 then exit;
{$endif}
tkRecord{$ifdef FPC},tkObject{$endif}:
// RecordEquals() works with packed records containing binary and string types
for result := 0 to max do
if RecordEquals(P^,Elem,ElemType) then
exit else
inc(PByte(P),ElemSize);
tkInterface:
for result := 0 to max do
if P^[result]=pointer(Elem) then exit;
else
for result := 0 to max do
if ManagedTypeCompare(pointer(P),@Elem,ElemType)>0 then
exit else
inc(PByte(P),ElemSize);
end;
end;
result := -1;
end;
procedure TDynArray.Init(aTypeInfo: pointer; var aValue; aCountPointer: PInteger);
begin
fValue := @aValue;
fTypeInfo := aTypeInfo;
if PTypeKind(aTypeInfo)^<>tkDynArray then // inlined GetTypeInfo()
raise ESynException.CreateUTF8('TDynArray.Init: % is %, expected tkDynArray',
[ArrayTypeShort^,ToText(PTypeKind(aTypeInfo)^)^]);
{$ifdef HASALIGNTYPEDATA}
aTypeInfo := FPCTypeInfoOverName(aTypeInfo);
{$else}
inc(PByte(aTypeInfo),PTypeInfo(aTypeInfo)^.NameLen);
{$endif}
fElemSize := PTypeInfo(aTypeInfo)^.elSize {$ifdef FPC}and $7FFFFFFF{$endif};
fElemType := PTypeInfo(aTypeInfo)^.elType;
if fElemType<>nil then begin // inlined DeRef()
{$ifndef HASDIRECTTYPEINFO}
// FPC compatibility: if you have a GPF here at startup, your 3.1 trunk
// revision seems older than June 2016
// -> enable HASDIRECTTYPEINFO conditional below $ifdef VER3_1 in Synopse.inc
// or in your project's options
fElemType := PPointer(fElemType)^;
{$endif HASDIRECTTYPEINFO}
{$ifdef FPC}
if not (PTypeKind(fElemType)^ in tkManagedTypes) then
fElemType := nil; // as with Delphi
{$endif FPC}
end;
{$ifdef DYNARRAYELEMTYPE2} // disabled not to break backward compatibility
fElemType2 := PTypeInfo(aTypeInfo)^.elType2;
{$endif}
fCountP := aCountPointer;
if fCountP<>nil then
fCountP^ := 0;
fCompare := nil;
fParser := DYNARRAY_PARSERUNKNOWN;
fKnownSize := 0;
fSorted := false;
fKnownType := djNone;
fIsObjArray := oaUnknown;
end;
procedure TDynArray.InitSpecific(aTypeInfo: pointer; var aValue; aKind: TDynArrayKind;
aCountPointer: PInteger; aCaseInsensitive: boolean);
var Comp: TDynArraySortCompare;
begin
Init(aTypeInfo,aValue,aCountPointer);
Comp := DYNARRAY_SORTFIRSTFIELD[aCaseInsensitive,aKind];
if @Comp=nil then
raise ESynException.CreateUTF8('TDynArray.InitSpecific(%) wrong aKind=%',
[ArrayTypeShort^,ToText(aKind)^]);
fCompare := Comp;
fKnownType := aKind;
fKnownSize := KNOWNTYPE_SIZE[aKind];
end;
procedure TDynArray.UseExternalCount(var aCountPointer: Integer);
begin
fCountP := @aCountPointer;
end;
function TDynArray.HasCustomJSONParser: boolean;
begin
if fParser=DYNARRAY_PARSERUNKNOWN then
fParser := GlobalJSONCustomParsers.DynArraySearch(ArrayType,ElemType);
result := cardinal(fParser)<cardinal(GlobalJSONCustomParsers.fParsersCount);
end;
procedure TDynArray.Void;
begin
fValue := nil;
end;
function TDynArray.IsVoid: boolean;
begin
result := fValue=nil;
end;
function TDynArray.ComputeIsObjArray: boolean;
begin
result := (fElemSize=SizeOf(pointer)) and (fElemType=nil) and
Assigned(DynArrayIsObjArray) and (DynArrayIsObjArray(fTypeInfo)<>nil);
if result then
fIsObjArray := oaTrue else
fIsObjArray := oaFalse;
end;
procedure TDynArray.SetIsObjArray(aValue: boolean);
begin
if aValue then
fIsObjArray := oaTrue else
fIsObjArray := oaFalse;
end;
procedure TDynArray.InternalSetLength(OldLength,NewLength: PtrUInt);
var p: PDynArrayRec;
NeededSize, minLength: PtrUInt;
pp: pointer;
begin // this method is faster than default System.DynArraySetLength() function
p := fValue^;
// check that new array length is not just a finalize in disguise
if NewLength=0 then begin
if p<>nil then begin // FastDynArrayClear() with ObjArray support
dec(p);
if (p^.refCnt>=0) and DACntDecFree(p^.refCnt) then begin
if OldLength<>0 then
if ElemType<>nil then
FastFinalizeArray(fValue^,ElemType,OldLength) else
if GetIsObjArray then
RawObjectsClear(fValue^,OldLength);
FreeMem(p);
end;
fValue^ := nil;
end;
exit;
end;
// calculate the needed size of the resulting memory structure on heap
NeededSize := NewLength*ElemSize+SizeOf(TDynArrayRec);
{$ifndef CPU64}
if NeededSize>1024*1024*1024 then // max workable memory block is 1 GB
raise ERangeError.CreateFmt('TDynArray SetLength(%s,%d) size concern',
[ArrayTypeShort^,NewLength]);
{$endif}
// if not shared (refCnt=1), resize; if shared, create copy (not thread safe)
if p=nil then begin
p := AllocMem(NeededSize); // RTL/OS will return zeroed memory
OldLength := NewLength; // no FillcharFast() below
end else begin
dec(PtrUInt(p),SizeOf(TDynArrayRec)); // p^ = start of heap object
if (p^.refCnt>=0) and DACntDecFree(p^.refCnt) then begin
if NewLength<OldLength then // reduce array in-place
if ElemType<>nil then // release managed types in trailing items
FastFinalizeArray(pointer(PAnsiChar(p)+NeededSize),ElemType,OldLength-NewLength) else
if GetIsObjArray then // FreeAndNil() of resized objects list
RawObjectsClear(pointer(PAnsiChar(p)+NeededSize),OldLength-NewLength);
ReallocMem(p,NeededSize);
end else begin // make copy
GetMem(p,NeededSize);
minLength := OldLength;
if minLength>NewLength then
minLength := NewLength;
pp := PAnsiChar(p)+SizeOf(TDynArrayRec);
if ElemType<>nil then begin
FillCharFast(pp^,minLength*elemSize,0);
CopyArray(pp,fValue^,ElemType,minLength);
end else
MoveFast(fValue^^,pp^,minLength*elemSize);
end;
end;
// set refCnt=1 and new length to the heap header
with p^ do begin
refCnt := 1;
{$ifdef FPC}
high := newLength-1;
{$else}
length := newLength;
{$endif}
end;
inc(PByte(p),SizeOf(p^)); // p^ = start of dynamic aray items
fValue^ := p;
// reset new allocated elements content to zero
if NewLength>OldLength then begin
OldLength := OldLength*elemSize;
FillCharFast(PAnsiChar(p)[OldLength],NewLength*ElemSize-OldLength,0);
end;
end;
procedure TDynArray.SetCount(aCount: PtrInt);
const MINIMUM_SIZE = 64;
var oldlen, extcount, arrayptr, capa, delta: PtrInt;
begin
arrayptr := PtrInt(fValue);
extcount := PtrInt(fCountP);
fSorted := false;
if arrayptr=0 then
exit; // avoid GPF if void
arrayptr := PPtrInt(arrayptr)^;
if extcount<>0 then begin // fCountP^ as external capacity
oldlen := PInteger(extcount)^;
delta := aCount-oldlen;
if delta=0 then
exit;
PInteger(extcount)^ := aCount; // store new length
if arrayptr=0 then begin // void array
if (delta>0) and (aCount<MINIMUM_SIZE) then
aCount := MINIMUM_SIZE; // reserve some minimal (64) items for Add()
end else begin
capa := PDALen(arrayptr-_DALEN)^{$ifdef FPC}+1{$endif};
if delta>0 then begin // size-up
if capa>=aCount then
exit; // no need to grow
capa := NextGrow(capa);
if capa>aCount then
aCount := capa; // grow by chunks
end else // size-down
if (aCount>0) and ((capa<=MINIMUM_SIZE) or (capa-aCount<capa shr 3)) then
exit; // reallocate memory only if worth it (for faster Delete)
end;
end else // no external capacity: use length()
if arrayptr=0 then
oldlen := arrayptr else begin
oldlen := PDALen(arrayptr-_DALEN)^{$ifdef FPC}+1{$endif};
if oldlen=aCount then
exit; // InternalSetLength(samecount) would make a private copy
end;
// no external Count, array size-down or array up-grow -> realloc
InternalSetLength(oldlen,aCount);
end;
function TDynArray.GetCapacity: PtrInt;
begin // capacity = length(DynArray)
result := PtrInt(fValue);
if result<>0 then begin
result := PPtrInt(result)^;
if result<>0 then
result := PDALen(result-_DALEN)^{$ifdef FPC}+1{$endif};
end;
end;
procedure TDynArray.SetCapacity(aCapacity: PtrInt);
var oldlen,capa: PtrInt;
begin
if fValue=nil then
exit;
capa := GetCapacity;
if fCountP<>nil then begin
oldlen := fCountP^;
if oldlen>aCapacity then
fCountP^ := aCapacity;
end else
oldlen := capa;
if capa<>aCapacity then
InternalSetLength(oldlen,aCapacity);
end;
procedure TDynArray.SetCompare(const aCompare: TDynArraySortCompare);
begin
if @aCompare<>@fCompare then begin
@fCompare := @aCompare;
fSorted := false;
end;
end;
procedure TDynArray.Slice(var Dest; aCount, aFirstIndex: cardinal);
var n: Cardinal;
D: PPointer;
P: PAnsiChar;
begin
if fValue=nil then
exit; // avoid GPF if void
n := GetCount;
if aFirstIndex>=n then
aCount := 0 else
if aCount>=n-aFirstIndex then
aCount := n-aFirstIndex;
DynArray(ArrayType,Dest).SetCapacity(aCount);
if aCount>0 then begin
D := @Dest;
P := PAnsiChar(fValue^)+aFirstIndex*ElemSize;
if ElemType=nil then
MoveFast(P^,D^^,aCount*ElemSize) else
CopyArray(D^,P,ElemType,aCount);
end;
end;
function TDynArray.AddArray(const DynArrayVar; aStartIndex, aCount: integer): integer;
var c, n: integer;
PS,PD: pointer;
begin
result := 0;
if fValue=nil then
exit; // avoid GPF if void
c := DynArrayLength(pointer(DynArrayVar));
if aStartIndex>=c then
exit; // nothing to copy
if (aCount<0) or (cardinal(aStartIndex+aCount)>cardinal(c)) then
aCount := c-aStartIndex;
if aCount<=0 then
exit;
result := aCount;
n := GetCount;
SetCount(n+aCount);
PS := pointer(PtrUInt(DynArrayVar)+cardinal(aStartIndex)*ElemSize);
PD := pointer(PtrUInt(fValue^)+cardinal(n)*ElemSize);
if ElemType=nil then
MoveFast(PS^,PD^,cardinal(aCount)*ElemSize) else
CopyArray(PD,PS,ElemType,aCount);
end;
procedure TDynArray.ElemClear(var Elem);
begin
if @Elem=nil then
exit; // avoid GPF
if ElemType<>nil then
{$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(@Elem,ElemType) else
if (fIsObjArray=oaTrue) or ((fIsObjArray=oaUnknown) and ComputeIsObjArray) then
TObject(Elem).Free;
FillCharFast(Elem,ElemSize,0); // always
end;
function TDynArray.ElemLoad(Source,SourceMax: PAnsiChar): RawByteString;
begin
if (Source<>nil) and (ElemType=nil) then
SetString(result,Source,ElemSize) else begin
SetString(result,nil,ElemSize);
FillCharFast(pointer(result)^,ElemSize,0);
ElemLoad(Source,pointer(result)^);
end;
end;
procedure TDynArray.ElemLoadClear(var ElemTemp: RawByteString);
begin
ElemClear(pointer(ElemTemp));
ElemTemp := '';
end;
procedure TDynArray.ElemLoad(Source: PAnsiChar; var Elem; SourceMax: PAnsiChar);
begin
if Source<>nil then // avoid GPF
if ElemType=nil then begin
if (SourceMax=nil) or (Source+ElemSize<=SourceMax) then
MoveFast(Source^,Elem,ElemSize);
end else
ManagedTypeLoad(@Elem,Source,ElemType,SourceMax);
end;
function TDynArray.ElemSave(const Elem): RawByteString;
var itemsize: integer;
begin
if ElemType=nil then
SetString(result,PAnsiChar(@Elem),ElemSize) else begin
SetString(result,nil,ManagedTypeSaveLength(@Elem,ElemType,itemsize));
if result<>'' then
ManagedTypeSave(@Elem,pointer(result),ElemType,itemsize);
end;
end;
function TDynArray.ElemLoadFind(Source, SourceMax: PAnsiChar): integer;
var tmp: array[0..2047] of byte;
data: pointer;
begin
result := -1;
if (Source=nil) or (ElemSize>SizeOf(tmp)) then
exit;
if ElemType=nil then
data := Source else begin
FillCharFast(tmp,ElemSize,0);
ManagedTypeLoad(@tmp,Source,ElemType,SourceMax);
if Source=nil then
exit;
data := @tmp;
end;
try
if @fCompare=nil then
result := IndexOf(data^) else
result := Find(data^);
finally
if ElemType<>nil then
{$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(data,ElemType);
end;
end;
{ TDynArrayLoadFrom }
function TDynArrayLoadFrom.Init(ArrayTypeInfo: pointer; Source: PAnsiChar;
SourceMaxLen: PtrInt): boolean;
var fake: pointer;
begin
result := false;
Position := nil; // force Step() to return false if called aterwards
if Source=nil then
exit;
if SourceMaxLen=0 then
PositionEnd := nil else
PositionEnd := Source+SourceMaxLen;
DynArray.Init(ArrayTypeInfo,fake); // just to retrieve RTTI
Count := DynArray.LoadFromHeader(PByte(Source),PByte(PositionEnd));
if Count<0 then
exit;
Hash := pointer(Source);
Position := @Hash[1];
Current := 0;
result := true;
end;
function TDynArrayLoadFrom.Init(ArrayTypeInfo: pointer; const Source: RawByteString): boolean;
begin
result := Init(ArrayTypeInfo,pointer(Source),length(Source));
end;
function TDynArrayLoadFrom.Step(out Elem): boolean;
begin
result := false;
if (Position<>nil) and (Current<Count) then begin
if DynArray.ElemType=nil then begin
if (PositionEnd<>nil) and (Position+DynArray.ElemSize>PositionEnd) then
exit;
MoveFast(Position^,Elem,DynArray.ElemSize);
inc(Position,DynArray.ElemSize);
end else begin
ManagedTypeLoad(@Elem,Position,DynArray.ElemType,PositionEnd);
if Position=nil then
exit;
end;
inc(Current);
result := true;
end;
end;
function TDynArrayLoadFrom.FirstField(out Field): boolean;
begin
if (Position<>nil) and (Current<Count) then
result := DynArray.LoadKnownType(@Field,Position,PositionEnd) else
result := false;
end;
function TDynArrayLoadFrom.CheckHash: boolean;
begin
result := (Position<>nil) and (Hash32(@Hash[1],Position-PAnsiChar(@Hash[1]))=Hash[0]);
end;
{ TDynArrayHasher }
function HashFile(const FileName: TFileName; Hasher: THasher): cardinal;
var buf: array[word] of cardinal; // 256KB of buffer
read: integer;
f: THandle;
begin
if not Assigned(Hasher) then
Hasher := DefaultHasher;
result := 0;
f := FileOpenSequentialRead(FileName);
if PtrInt(f)>=0 then begin
repeat
read := FileRead(f,buf,SizeOf(buf));
if read<=0 then
break;
result := Hasher(result,@buf,read);
until false;
FileClose(f);
end;
end;
function HashAnsiString(const Elem; Hasher: THasher): cardinal;
begin
if PtrUInt(Elem)=0 then
result := 0 else
result := Hasher(0,Pointer(Elem),PStrLen(PtrUInt(Elem)-_STRLEN)^);
end;
function HashAnsiStringI(const Elem; Hasher: THasher): cardinal;
var tmp: array[byte] of AnsiChar; // avoid slow heap allocation
begin
if PtrUInt(Elem)=0 then
result := 0 else
result := Hasher(0,tmp,UpperCopy255Buf(tmp,
pointer(Elem),PStrLen(PtrUInt(Elem)-_STRLEN)^)-tmp);
end;
{$ifdef UNICODE}
function HashUnicodeString(const Elem; Hasher: THasher): cardinal;
begin
if PtrUInt(Elem)=0 then
result := 0 else
result := Hasher(0,Pointer(Elem),length(UnicodeString(Elem))*2);
end;
function HashUnicodeStringI(const Elem; Hasher: THasher): cardinal;
var tmp: array[byte] of AnsiChar; // avoid slow heap allocation
begin
if PtrUInt(Elem)=0 then
result := 0 else
result := Hasher(0,tmp,UpperCopy255W(tmp,Pointer(Elem),length(UnicodeString(Elem)))-tmp);
end;
{$endif UNICODE}
function HashSynUnicode(const Elem; Hasher: THasher): cardinal;
begin
if PtrUInt(Elem)=0 then
result := 0 else
result := Hasher(0,Pointer(Elem),length(SynUnicode(Elem))*2);
end;
function HashSynUnicodeI(const Elem; Hasher: THasher): cardinal;
var tmp: array[byte] of AnsiChar; // avoid slow heap allocation
begin
if PtrUInt(Elem)=0 then
result := 0 else
result := Hasher(0,tmp,UpperCopy255W(tmp,SynUnicode(Elem))-tmp);
end;
function HashWideString(const Elem; Hasher: THasher): cardinal;
begin // WideString internal size is in bytes, not WideChar
if PtrUInt(Elem)=0 then
result := 0 else
result := Hasher(0,Pointer(Elem),Length(WideString(Elem))*2);
end;
function HashWideStringI(const Elem; Hasher: THasher): cardinal;
var tmp: array[byte] of AnsiChar; // avoid slow heap allocation
begin
if PtrUInt(Elem)=0 then
result := 0 else
result := Hasher(0,tmp,UpperCopy255W(tmp,pointer(Elem),Length(WideString(Elem)))-tmp);
end;
function HashPtrUInt(const Elem; Hasher: THasher): cardinal;
begin
result := Hasher(0,@Elem,SizeOf(PtrUInt));
end;
function HashPointer(const Elem; Hasher: THasher): cardinal;
begin
result := Hasher(0,@Elem,SizeOf(pointer));
end;
function HashByte(const Elem; Hasher: THasher): cardinal;
begin
result := Hasher(0,@Elem,SizeOf(byte));
end;
function HashWord(const Elem; Hasher: THasher): cardinal;
begin
result := Hasher(0,@Elem,SizeOf(word));
end;
function HashInteger(const Elem; Hasher: THasher): cardinal;
begin
result := Hasher(0,@Elem,SizeOf(integer));
end;
function HashInt64(const Elem; Hasher: THasher): cardinal;
begin
result := Hasher(0,@Elem,SizeOf(Int64));
end;
function Hash128(const Elem; Hasher: THasher): cardinal;
begin
result := Hasher(0,@Elem,SizeOf(THash128));
end;
function Hash256(const Elem; Hasher: THasher): cardinal;
begin
result := Hasher(0,@Elem,SizeOf(THash256));
end;
function Hash512(const Elem; Hasher: THasher): cardinal;
begin
result := Hasher(0,@Elem,SizeOf(THash512));
end;
{$ifndef NOVARIANTS}
function VariantHash(const value: variant; CaseInsensitive: boolean;
Hasher: THasher): cardinal;
var Up: array[byte] of AnsiChar; // avoid heap allocation
vt: cardinal;
procedure ComplexType;
var tmp: RawUTF8;
begin // slow but always working conversion to string
VariantSaveJSON(value,twNone,tmp);
if CaseInsensitive then
result := Hasher(vt,Up,UpperCopy255(Up,tmp)-Up) else
result := Hasher(vt,pointer(tmp),length(tmp));
end;
begin
if not Assigned(Hasher) then
Hasher := DefaultHasher;
vt := TVarData(value).VType;
with TVarData(value) do
case vt of
varNull, varEmpty:
result := vt; // good enough for void values
varShortInt, varByte:
result := Hasher(vt,@VByte,1);
varSmallint, varWord, varBoolean:
result := Hasher(vt,@VWord,2);
varLongWord, varInteger, varSingle:
result := Hasher(vt,@VLongWord,4);
varInt64, varDouble, varDate, varCurrency, varWord64:
result := Hasher(vt,@VInt64,SizeOf(Int64));
varString:
if CaseInsensitive then
result := Hasher(vt,Up,UpperCopy255Buf(Up,VString,length(RawUTF8(VString)))-Up) else
result := Hasher(vt,VString,length(RawUTF8(VString)));
varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}:
if CaseInsensitive then
result := Hasher(vt,Up,UpperCopy255W(Up,VOleStr,StrLenW(VOleStr))-Up) else
result := Hasher(vt,VAny,StrLenW(VOleStr)*2);
else
ComplexType;
end;
end;
function HashVariant(const Elem; Hasher: THasher): cardinal;
begin
result := VariantHash(variant(Elem),false,Hasher);
end;
function HashVariantI(const Elem; Hasher: THasher): cardinal;
begin
result := VariantHash(variant(Elem),true,Hasher);
end;
{$endif NOVARIANTS}
procedure TDynArrayHasher.Init(aDynArray: PDynArray; aHashElement: TDynArrayHashOne;
aEventHash: TEventDynArrayHashOne; aHasher: THasher; aCompare: TDynArraySortCompare;
aEventCompare: TEventDynArraySortCompare; aCaseInsensitive: boolean);
begin
DynArray := aDynArray;
if @aHasher=nil then
Hasher := DefaultHasher else
Hasher := aHasher;
HashElement := aHashElement;
EventHash := aEventHash;
if (@HashElement=nil) and (@EventHash=nil) then // fallback to first field RTTI
HashElement := DYNARRAY_HASHFIRSTFIELD[aCaseInsensitive,DynArray^.GuessKnownType];
Compare := aCompare;
EventCompare := aEventCompare;
if (@Compare=nil) and (@EventCompare=nil) then
Compare := DYNARRAY_SORTFIRSTFIELD[aCaseInsensitive,DynArray^.GuessKnownType];
CountTrigger := 32;
Clear;
end;
procedure TDynArrayHasher.InitSpecific(aDynArray: PDynArray; aKind: TDynArrayKind;
aCaseInsensitive: boolean);
var cmp: TDynArraySortCompare;
hsh: TDynArrayHashOne;
begin
cmp := DYNARRAY_SORTFIRSTFIELD[aCaseInsensitive,aKind];
hsh := DYNARRAY_HASHFIRSTFIELD[aCaseInsensitive,aKind];
if (@hsh=nil) or (@cmp=nil) then
raise ESynException.CreateUTF8('TDynArrayHasher.InitSpecific: %?',[ToText(aKind)^]);
Init(aDynArray,hsh,nil,nil,cmp,nil,aCaseInsensitive)
end;
procedure TDynArrayHasher.Clear;
begin
HashTable := nil;
HashTableSize := 0;
ScanCounter := 0;
if Assigned(HashElement) or Assigned(EventHash) then
State := [hasHasher] else
byte(State) := 0;
end;
function TDynArrayHasher.HashOne(Elem: pointer): cardinal;
begin
if Assigned(EventHash) then
result := EventHash(Elem^) else
if Assigned(HashElement) then
result := HashElement(Elem^,Hasher) else
result := 0; // will be ignored afterwards for sure
end;
const // primes reduce memory consumption and enhance distribution
_PRIMES: array[0..38{$ifndef CPU32DELPHI}+15{$endif}] of integer = (
{$ifndef CPU32DELPHI} 31, 127, 251, 499, 797, 1259, 2011, 3203, 5087, 8089,
12853, 20399, 81649, 129607, 205759, {$endif}
// following HASH_PO2=2^18=262144 for Delphi Win32
326617, 411527, 518509, 653267, 823117, 1037059, 1306601, 1646237,
2074129, 2613229, 3292489, 4148279, 5226491, 6584983, 8296553, 10453007,
13169977, 16593127, 20906033, 26339969, 33186281, 41812097, 52679969,
66372617, 83624237, 105359939, 132745199, 167248483, 210719881, 265490441,
334496971, 421439783, 530980861, 668993977, 842879579, 1061961721,
1337987929, 1685759167, 2123923447);
function NextPrime(v: integer): integer; {$ifdef HASINLINE}inline;{$endif}
var i: PtrInt;
P: PIntegerArray;
begin
P := @_PRIMES;
for i := 0 to high(_PRIMES) do begin
result := P^[i];
if result>v then
exit;
end;
end;
function TDynArrayHasher.HashTableIndex(aHashCode: cardinal): cardinal;
begin
result := HashTableSize;
{$ifdef CPU32DELPHI} // Delphi Win32 is not efficient with 64-bit multiplication
if result>HASH_PO2 then
result := aHashCode mod result else
result := aHashCode and (result-1);
{$else} // FPC or dcc64 compile next line as very optimized asm
result := (QWord(aHashCode)*result)shr 32;
// see https://lemire.me/blog/2016/06/27/a-fast-alternative-to-the-modulo-reduction
{$endif CPU32DELPHI}
end;
function TDynArrayHasher.Find(aHashCode: cardinal; aForAdd: boolean): integer;
var first,last: integer;
ndx,siz: PtrInt;
P: PAnsiChar;
begin
P := DynArray^.Value^;
siz := DynArray^.ElemSize;
if not(canHash in State) then begin // Count=0 or Count<CountTrigger
if hasHasher in State then
for result := 0 to DynArray^.Count-1 do // O(n) linear search via hashing
if HashOne(P)=aHashCode then
exit else
inc(P,siz);
result := -1;
exit;
end;
result := HashTableIndex(aHashCode);
first := result;
last := HashTableSize;
repeat
ndx := HashTable[result]-1; // index+1 was stored
if ndx<0 then begin
result := -(result+1); // found void entry
exit;
end else
if not aForAdd and (HashOne(P+ndx*siz)=aHashCode) then begin
result := ndx;
exit;
end;
inc(result); // try next entry on hash collision
if result=last then
// reached the end -> search once from HashTable[0] to HashTable[first-1]
if result=first then
break else begin
result := 0;
last := first;
end;
until false;
RaiseFatalCollision('Find',aHashCode);
end;
function TDynArrayHasher.FindOrNew(aHashCode: cardinal; Elem: pointer;
aHashTableIndex: PInteger): integer;
var first,last,ndx,cmp: integer;
P: PAnsiChar;
begin
if not(canHash in State) then begin // e.g. Count<CountTrigger
result := Scan(Elem);
exit;
end;
result := HashTableIndex(aHashCode);
first := result;
last := HashTableSize;
repeat
ndx := HashTable[result]-1; // index+1 was stored
if ndx<0 then begin
result := -(result+1);
exit; // returns void index in HashTable[]
end;
with DynArray^ do
P := PAnsiChar(Value^)+cardinal(ndx)*ElemSize;
if Assigned(EventCompare) then
cmp := EventCompare(P^,Elem^) else
if Assigned(Compare) then
cmp := Compare(P^,Elem^) else
cmp := 1;
if cmp=0 then begin // faster than hash e.g. for huge strings
if aHashTableIndex<>nil then
aHashTableIndex^ := result;
result := ndx;
exit;
end;
// hash or slot collision -> search next item
{$ifdef DYNARRAYHASHCOLLISIONCOUNT}
inc(FindCollisions);
{$endif}
//inc(TDynArrayHashedCollisionCount);
inc(result);
if result=last then
// reached the end -> search once from HashTable[0] to HashTable[first-1]
if result=first then
break else begin
result := 0;
last := first;
end;
until false;
RaiseFatalCollision('FindOrNew',aHashCode);
end;
procedure TDynArrayHasher.HashAdd(aHashCode: cardinal; var result: integer);
var n: integer;
begin // on input: HashTable[result] slot is already computed
n := DynArray^.Count;
if HashTableSize<n then
RaiseFatalCollision('HashAdd HashTableSize',aHashCode);
if HashTableSize-n<n shr 2 then begin // grow hash table when 25% void
ReHash({foradd=}true);
result := Find(aHashCode,{foradd=}true); // recompute position
if result>=0 then
RaiseFatalCollision('HashAdd',aHashCode);
end;
HashTable[-result-1] := n+1; // store Index+1 (0 means void slot)
result := n;
end; // on output: result holds the position in fValue[]
// brute force O(n) indexes fix after deletion (much faster than full ReHash)
procedure DynArrayHashTableAdjust(P: PIntegerArray; deleted: integer; count: PtrInt);
{$ifdef CPUX64ASM} // SSE2 simd is 25x faster than "if P^>deleted then dec(P^)"
{$ifdef FPC}nostackframe; assembler; asm {$else}
asm .noframe // rcx=P, edx=deleted, r8=count (Linux: rdi,esi,rdx)
{$endif FPC}
{$ifdef Linux}
mov r8, rdx
mov rcx, rdi
mov rdx, rsi
{$endif Linux}
xor eax, eax // reset eax high bits for setg al below
movq xmm0, rdx // xmm0 = 128-bit of quad deleted
pshufd xmm0, xmm0, 0
test cl, 3
jnz @1 // paranoid: a dword dynamic array is always dword-aligned
// ensure P is 256-bit aligned (for avx2)
@align: test cl, 31
jz @ok
cmp dword ptr[rcx], edx
setg al // P[]>deleted -> al=1, 0 otherwise
sub dword ptr[rcx], eax // branchless dec(P[])
add rcx, 4
dec r8
jmp @align
@ok: {$ifdef FPC} // AVX2 asm is not supported by Delphi (even 10.3) :(
test byte ptr[rip+CPUIDX64], 1 shl cpuAVX2
jz @sse2
vpshufd ymm0, ymm0, 0 // shuffle to ymm0 128-bit low lane
vperm2f128 ymm0, ymm0, ymm0, 0 // copy to ymm0 128-bit high lane
// avx process of 128 bytes (32 indexes) per loop iteration
align 16
@avx2: sub r8, 32
vmovdqa ymm1, [rcx] // 4 x 256-bit process = 4 x 8 integers
vmovdqa ymm3, [rcx + 32]
vmovdqa ymm5, [rcx + 64]
vmovdqa ymm7, [rcx + 96]
vpcmpgtd ymm2, ymm1, ymm0 // compare P[]>deleted -> -1, 0 otherwise
vpcmpgtd ymm4, ymm3, ymm0
vpcmpgtd ymm6, ymm5, ymm0
vpcmpgtd ymm8, ymm7, ymm0
vpaddd ymm1, ymm1, ymm2 // adjust by adding -1 / 0
vpaddd ymm3, ymm3, ymm4
vpaddd ymm5, ymm5, ymm6
vpaddd ymm7, ymm7, ymm8
vmovdqa [rcx], ymm1
vmovdqa [rcx + 32], ymm3
vmovdqa [rcx + 64], ymm5
vmovdqa [rcx + 96], ymm7
add rcx, 128
cmp r8, 32
jae @avx2
vzeroupper
jmp @2
{$endif FPC}
// SSE2 process of 64 bytes (16 indexes) per loop iteration
{$ifdef FPC} align 16 {$else} .align 16 {$endif}
@sse2: sub r8, 16
movaps xmm1, dqword [rcx] // 4 x 128-bit process = 4 x 4 integers
movaps xmm3, dqword [rcx + 16]
movaps xmm5, dqword [rcx + 32]
movaps xmm7, dqword [rcx + 48]
movaps xmm2, xmm1 // keep copy for paddd below
movaps xmm4, xmm3
movaps xmm6, xmm5
movaps xmm8, xmm7
pcmpgtd xmm1, xmm0 // quad compare P[]>deleted -> -1, 0 otherwise
pcmpgtd xmm3, xmm0
pcmpgtd xmm5, xmm0
pcmpgtd xmm7, xmm0
paddd xmm1, xmm2 // quad adjust by adding -1 / 0
paddd xmm3, xmm4
paddd xmm5, xmm6
paddd xmm7, xmm8
movaps dqword [rcx], xmm1 // quad store back
movaps dqword [rcx + 16], xmm3
movaps dqword [rcx + 32], xmm5
movaps dqword [rcx + 48], xmm7
add rcx, 64
cmp r8, 16
jae @sse2
jmp @2
// trailing indexes
@1: dec r8
cmp dword ptr[rcx + r8 * 4], edx
setg al
sub dword ptr[rcx + r8 * 4], eax
@2: test r8, r8
jnz @1
end;
{$else}
begin
repeat
dec(count,8);
dec(P[0],ord(P[0]>deleted)); // branchless code is 10x faster than if :)
dec(P[1],ord(P[1]>deleted));
dec(P[2],ord(P[2]>deleted));
dec(P[3],ord(P[3]>deleted));
dec(P[4],ord(P[4]>deleted));
dec(P[5],ord(P[5]>deleted));
dec(P[6],ord(P[6]>deleted));
dec(P[7],ord(P[7]>deleted));
P := @P[8];
until count<8;
while count>0 do begin
dec(count);
dec(P[count],ord(P[count]>deleted));
end;
end;
{$endif CPUX64ASM} // SSE2 asm is invalid prior to Delphi XE7 (to be refined)
// with x86_64/sse2 for 200,000 items: adjust=200.57ms (11.4GB/s) hash=2.46ms
// -> TDynArray.Delete move() takes more time than the HashTable update :)
{ some numbers, with CITIES_MAX=200000, deleting 1/128 entries
first column (3..23) is the max number of indexes[] chunk to rehash
1. naive loop
for i := 0 to HashTableSize-1 do
if HashTable[i]>aArrayIndex then
dec(HashTable[i]);
3 #257 adjust=7.95ms 191.7MB hash=8us
8 #384 adjust=11.93ms 255.8MB hash=10us
11 #1019 adjust=32.09ms 332.8MB hash=26us
13 #16259 adjust=511.10ms 379.2MB hash=230us
13 #32515 adjust=1.01s 383.6MB/s hash=440us
14 #33531 adjust=1.04s 382.2MB hash=459us
17 #46612 adjust=1.44s 386.3MB hash=639us
17 #65027 adjust=1.97s 396.3MB/s hash=916us
17 #97539 adjust=2.79s 419.9MB/s hash=1.37ms
18 #109858 adjust=3.05s 431.2MB hash=1.51ms
18 #130051 adjust=3.44s 454.1MB/s hash=1.75ms
18 #162563 adjust=3.93s 496.9MB/s hash=2.14ms
23 #172723 adjust=4.05s 511.7MB hash=2.26ms
23 #195075 adjust=4.27s 548.6MB/s hash=2.47ms
2. branchless pure pascal code is about 10x faster!
3 #257 adjust=670us 2.2GB hash=8us
8 #384 adjust=1ms 2.9GB hash=9us
11 #1019 adjust=2.70ms 3.8GB hash=21us
13 #16259 adjust=43.65ms 4.3GB hash=210us
13 #32515 adjust=87.75ms 4.3GB/s hash=423us
14 #33531 adjust=90.44ms 4.3GB hash=441us
17 #46612 adjust=127.68ms 4.2GB hash=627us
17 #65027 adjust=179.64ms 4.2GB/s hash=908us
17 #97539 adjust=267.44ms 4.2GB/s hash=1.35ms
18 #109858 adjust=301.27ms 4.2GB hash=1.50ms
18 #130051 adjust=355.37ms 4.2GB/s hash=1.74ms
18 #162563 adjust=438.79ms 4.3GB/s hash=2.11ms
23 #172723 adjust=465.23ms 4.3GB hash=2.23ms
23 #195075 adjust=520.85ms 4.3GB/s hash=2.45ms
3. SSE2 simd assembly makes about 3x improvement
3 #257 adjust=290us 5.1GB hash=8us
8 #384 adjust=427us 6.9GB hash=10us
11 #1019 adjust=1.11ms 9.3GB hash=20us
13 #16259 adjust=18.33ms 10.3GB hash=219us
13 #32515 adjust=36.32ms 10.5GB/s hash=435us
14 #33531 adjust=37.39ms 10.4GB hash=452us
17 #46612 adjust=51.70ms 10.5GB hash=622us
17 #65027 adjust=72.47ms 10.5GB/s hash=893us
17 #97539 adjust=107ms 10.6GB/s hash=1.32ms
18 #109858 adjust=120.08ms 10.7GB hash=1.46ms
18 #130051 adjust=140.50ms 10.8GB/s hash=1.71ms
18 #162563 adjust=171.44ms 11.1GB/s hash=2.10ms
23 #172723 adjust=181.02ms 11.1GB hash=2.22ms
23 #195075 adjust=201.53ms 11.3GB/s hash=2.44ms
4. AVX2 simd assembly gives some additional 40% (consistent on my iCore3 cpu)
3 #257 adjust=262us 5.6GB hash=8us
8 #384 adjust=383us 7.7GB hash=10us
11 #1019 adjust=994us 10.4GB hash=21us
13 #16259 adjust=16.34ms 11.5GB hash=248us
13 #32515 adjust=32.12ms 11.8GB/s hash=464us
14 #33531 adjust=33.06ms 11.8GB hash=484us
17 #46612 adjust=45.49ms 11.9GB hash=678us
17 #65027 adjust=62.36ms 12.2GB/s hash=966us
17 #97539 adjust=90.80ms 12.6GB/s hash=1.43ms
18 #109858 adjust=101.82ms 12.6GB hash=1.59ms
18 #130051 adjust=117.37ms 13GB/s hash=1.83ms
18 #162563 adjust=140.08ms 13.6GB/s hash=2.23ms
23 #172723 adjust=147.20ms 13.7GB hash=2.34ms
23 #195075 adjust=161.73ms 14.1GB/s hash=2.57ms
}
procedure TDynArrayHasher.HashDelete(aArrayIndex,aHashTableIndex: integer; aHashCode: cardinal);
var first,next,last,ndx,i,n: integer;
P: PAnsiChar;
indexes: array[0..511] of cardinal; // to be rehashed
begin
// retrieve hash table entries to be recomputed
first := aHashTableIndex;
last := HashTableSize;
next := first;
n := 0;
repeat
HashTable[next] := 0; // Clear slots
inc(next);
if next=last then
if next=first then
RaiseFatalCollision('HashDelete down',aHashCode) else begin
next := 0;
last := first;
end;
ndx := HashTable[next]-1; // stored index+1
if ndx<0 then
break; // stop at void entry
if n=high(indexes) then // typical 0..23
RaiseFatalCollision('HashDelete indexes overflow',aHashCode);
indexes[n] := ndx;
inc(n);
until false;
// ReHash collided entries - note: item is not yet deleted in Value^[]
for i := 0 to n-1 do begin
P := PAnsiChar(DynArray^.Value^)+indexes[i]*DynArray^.ElemSize;
ndx := FindOrNew(HashOne(P),P,nil);
if ndx<0 then
HashTable[-ndx-1] := indexes[i]+1; // ignore ndx>=0 dups (like ReHash)
end;
// adjust all stored indexes
DynArrayHashTableAdjust(pointer(HashTable),aArrayIndex,HashTableSize);
end;
function TDynArrayHasher.FindBeforeAdd(Elem: pointer;
out wasAdded: boolean; aHashCode: cardinal): integer;
var n: integer;
begin
wasAdded := false;
if not(canHash in State) then begin
n := DynArray^.Count;
if n<CountTrigger then begin
result := Scan(Elem); // may trigger ReHash and set canHash
if result>=0 then
exit; // item found
if not(canHash in State) then begin
wasadded := true;
result := n;
exit;
end;
end;
end;
if not(canHash in State) then
ReHash({forced=}true); // hash previous CountTrigger items
result := FindOrNew(aHashCode,Elem,nil);
if result<0 then begin // found no matching item
wasAdded := true;
HashAdd(aHashCode,result);
end;
end;
function TDynArrayHasher.FindBeforeDelete(Elem: pointer): integer;
var hc: cardinal;
ht: integer;
begin
if canHash in State then begin
hc := HashOne(Elem);
result := FindOrNew(hc,Elem,@ht);
if result<0 then
result := -1 else
HashDelete(result,ht,hc);
end else
result := Scan(Elem);
end;
procedure TDynArrayHasher.RaiseFatalCollision(const caller: RawUTF8;
aHashCode: cardinal);
begin // a dedicated sub-procedure reduces code size
raise ESynException.CreateUTF8('TDynArrayHasher.% fatal collision: '+
'aHashCode=% HashTableSize=% Count=% Capacity=% ArrayType=% KnownType=%',
[caller,CardinalToHexShort(aHashCode),HashTableSize,DynArray^.Count,
DynArray^.Capacity,DynArray^.ArrayTypeShort^,ToText(DynArray^.KnownType)^]);
end;
function TDynArrayHasher.GetHashFromIndex(aIndex: PtrInt): cardinal;
var P: pointer;
begin
P := DynArray^.ElemPtr(aIndex);
if P<>nil then
result := HashOne(P) else
result := 0;
end;
procedure TDynArrayHasher.SetEventHash(const event: TEventDynArrayHashOne);
begin
EventHash := event;
Clear;
end;
function TDynArrayHasher.Scan(Elem: pointer): integer;
var P: PAnsiChar;
i,max: integer;
siz: PtrInt;
begin
result := -1;
max := DynArray^.Count-1;
P := DynArray^.Value^;
siz := DynArray^.ElemSize;
if Assigned(EventCompare) then // custom comparison
for i := 0 to max do
if EventCompare(P^,Elem^)=0 then begin
result := i;
break;
end else
inc(P,siz) else
if Assigned(Compare) then
for i := 0 to max do
if Compare(P^,Elem^)=0 then begin
result := i;
break;
end else
inc(P,siz);
// enable hashing if Scan() called 2*CountTrigger
if (hasHasher in State) and (max>7) then begin
inc(ScanCounter);
if ScanCounter>=CountTrigger*2 then begin
CountTrigger := 2; // rather use hashing from now on
ReHash(false); // set HashTable[] and canHash
end;
end;
end;
function TDynArrayHasher.Find(Elem: pointer): integer;
begin
result := Find(Elem,HashOne(Elem));
end;
function TDynArrayHasher.Find(Elem: pointer; aHashCode: cardinal): integer;
begin
result := FindOrNew(aHashCode,Elem,nil); // fallback to Scan() if needed
if result<0 then
result := -1; // for coherency with most search methods
end;
function TDynArrayHasher.ReHash(forced: boolean): integer;
var i, n, cap, siz, ndx: integer;
P: PAnsiChar;
hc: cardinal;
begin
result := 0;
n := DynArray^.Count;
if not (Assigned(HashElement) or Assigned(EventHash)) or
(not forced and ((n=0) or (n<CountTrigger))) then begin
Clear; // reset HashTable[]
exit; // hash only if needed, and avoid GPF after TDynArray.Clear (Count=0)
end;
cap := DynArray^.Capacity * 2; // to reserve some void slots
{$ifdef CPU32DELPHI}
if cap<=HASH_PO2 then begin
siz := 256;
while siz<cap do // find nearest power of two for fast bitwise division
siz := siz shl 1;
end else
{$endif CPU32DELPHI}
siz := NextPrime(cap);
if (not forced) and (siz=HashTableSize) then
exit; // was a paranoid ReHash() call
Clear;
HashTableSize := siz;
SetLength(HashTable,siz); // fill with 0 (void slot)
// fill HashTable[]=index+1 from all existing items
include(State,canHash); // needed before Find() below
P := DynArray^.Value^;
for i := 1 to n do begin
if Assigned(EventHash) then
hc := EventHash(P^) else
hc := HashElement(P^,Hasher);
ndx := FindOrNew(hc,P,nil);
if ndx>=0 then
inc(result) else // found duplicated value
HashTable[-ndx-1] := i; // store index+1 (0 means void entry)
inc(P,DynArray^.ElemSize);
end;
end;
{ TDynArrayHashed }
{$ifdef UNDIRECTDYNARRAY} // some Delphi 2009+ wrapper definitions
function TDynArrayHashed.GetCount: PtrInt;
begin
result := InternalDynArray.GetCount;
end;
procedure TDynArrayHashed.SetCount(aCount: PtrInt);
begin
InternalDynArray.SetCount(aCount);
end;
function TDynArrayHashed.GetCapacity: PtrInt;
begin
result := InternalDynArray.GetCapacity;
end;
procedure TDynArrayHashed.SetCapacity(aCapacity: PtrInt);
begin
InternalDynArray.SetCapacity(aCapacity);
end;
function TDynArrayHashed.Value: PPointer;
begin
result := InternalDynArray.fValue;
end;
function TDynArrayHashed.ElemSize: PtrUInt;
begin
result := InternalDynArray.fElemSize;
end;
function TDynArrayHashed.ElemType: Pointer;
begin
result := InternalDynArray.fElemType;
end;
procedure TDynArrayHashed.ElemCopy(const A; var B);
begin
InternalDynArray.ElemCopy(A,B);
end;
function TDynArrayHashed.ElemPtr(index: PtrInt): pointer;
begin
result := InternalDynArray.ElemPtr(index);
end;
procedure TDynArrayHashed.ElemCopyAt(index: PtrInt; var Dest);
begin
InternalDynArray.ElemCopyAt(index,Dest);
end;
function TDynArrayHashed.KnownType: TDynArrayKind;
begin
result := InternalDynArray.KnownType;
end;
procedure TDynArrayHashed.Clear;
begin
InternalDynArray.SetCount(0);
end;
function TDynArrayHashed.Add(const Elem): integer;
begin
result := InternalDynArray.Add(Elem);
end;
procedure TDynArrayHashed.Delete(aIndex: PtrInt);
begin
InternalDynArray.Delete(aIndex);
end;
function TDynArrayHashed.SaveTo: RawByteString;
begin
result := InternalDynArray.SaveTo;
end;
function TDynArrayHashed.LoadFrom(Source: PAnsiChar; AfterEach: TDynArrayAfterLoadFrom;
NoCheckHash: boolean; SourceMax: PAnsiChar): PAnsiChar;
begin
result := InternalDynArray.LoadFrom(Source,AfterEach,NoCheckHash,SourceMax);
end;
function TDynArrayHashed.LoadFromBinary(const Buffer: RawByteString; NoCheckHash: boolean): boolean;
begin
result := InternalDynArray.LoadFromBinary(Buffer,NoCheckHash);
end;
function TDynArrayHashed.SaveTo(Dest: PAnsiChar): PAnsiChar;
begin
result := InternalDynArray.SaveTo(Dest);
end;
function TDynArrayHashed.SaveToJSON(EnumSetsAsText: boolean;
reformat: TTextWriterJSONFormat): RawUTF8;
begin
result := InternalDynArray.SaveToJSON(EnumSetsAsText,reformat);
end;
procedure TDynArrayHashed.Sort(aCompare: TDynArraySortCompare);
begin
InternalDynArray.Sort(aCompare);
end;
procedure TDynArrayHashed.CreateOrderedIndex(var aIndex: TIntegerDynArray;
aCompare: TDynArraySortCompare);
begin
InternalDynArray.CreateOrderedIndex(aIndex,aCompare);
end;
function TDynArrayHashed.LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char{$ifndef NOVARIANTS};
CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char;
begin
result := InternalDynArray.LoadFromJSON(P,aEndOfObject{$ifndef NOVARIANTS},
CustomVariantOptions{$endif});
end;
function TDynArrayHashed.SaveToLength: integer;
begin
result := InternalDynArray.SaveToLength;
end;
{$endif UNDIRECTDYNARRAY}
procedure TDynArrayHashed.Init(aTypeInfo: pointer; var aValue;
aHashElement: TDynArrayHashOne; aCompare: TDynArraySortCompare;
aHasher: THasher; aCountPointer: PInteger; aCaseInsensitive: boolean);
begin
{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$else}inherited{$endif}
Init(aTypeInfo,aValue,aCountPointer);
fHash.Init(@self,aHashElement,nil,aHasher,aCompare,nil,aCaseInsensitive);
{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}SetCompare(fHash.Compare);
end;
procedure TDynArrayHashed.InitSpecific(aTypeInfo: pointer; var aValue;
aKind: TDynArrayKind; aCountPointer: PInteger; aCaseInsensitive: boolean);
begin
{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$else}inherited{$endif}
Init(aTypeInfo,aValue,aCountPointer);
fHash.InitSpecific(@self,aKind,aCaseInsensitive);
{$ifdef UNDIRECTDYNARRAY}with InternalDynArray do{$endif} begin
fCompare := fHash.Compare;
fKnownType := aKind;
fKnownSize := KNOWNTYPE_SIZE[aKind];
end;
end;
function TDynArrayHashed.Scan(const Elem): integer;
begin
result := fHash.Scan(@Elem);
end;
function TDynArrayHashed.FindHashed(const Elem): integer;
begin
result := fHash.FindOrNew(fHash.HashOne(@Elem),@Elem);
if result<0 then
result := -1; // for coherency with most methods
end;
function TDynArrayHashed.FindFromHash(const Elem; aHashCode: cardinal): integer;
begin // overload FindHashed() trigger F2084 Internal Error: C2130 on Delphi XE3
result := fHash.FindOrNew(aHashCode,@Elem); // fallback to Scan() if needed
if result<0 then
result := -1; // for coherency with most methods
end;
function TDynArrayHashed.FindHashedForAdding(const Elem; out wasAdded: boolean;
noAddEntry: boolean): integer;
begin
result := FindHashedForAdding(Elem,wasAdded,fHash.HashOne(@Elem),noAddEntry);
end;
function TDynArrayHashed.FindHashedForAdding(const Elem; out wasAdded: boolean;
aHashCode: cardinal; noAddEntry: boolean): integer;
begin
result := fHash.FindBeforeAdd(@Elem,wasAdded,aHashCode);
if wasAdded and not noAddEntry then
SetCount(result+1); // reserve space for a void element in array
end;
function TDynArrayHashed.AddAndMakeUniqueName(aName: RawUTF8): pointer;
var ndx,j: integer;
added: boolean;
aName_: RawUTF8;
begin
if aName='' then
aName := '_';
ndx := FindHashedForAdding(aName,added);
if not added then begin // force unique column name
aName_ := aName+'_';
j := 1;
repeat
aName := aName_+UInt32ToUTF8(j);
ndx := FindHashedForAdding(aName,added);
inc(j);
until added;
end;
result := PAnsiChar(Value^)+cardinal(ndx)*ElemSize;
PRawUTF8(result)^ := aName; // store unique name at 1st elem position
end;
function TDynArrayHashed.AddUniqueName(const aName: RawUTF8; aNewIndex: PInteger): pointer;
begin
result := AddUniqueName(aName,'',[],aNewIndex);
end;
function TDynArrayHashed.AddUniqueName(const aName: RawUTF8;
const ExceptionMsg: RawUTF8; const ExceptionArgs: array of const; aNewIndex: PInteger): pointer;
var ndx: integer;
added: boolean;
begin
ndx := FindHashedForAdding(aName,added);
if added then begin
if aNewIndex<>nil then
aNewIndex^ := ndx;
result := PAnsiChar(Value^)+cardinal(ndx)*ElemSize;
PRawUTF8(result)^ := aName; // store unique name at 1st elem position
end else
if ExceptionMsg='' then
raise ESynException.CreateUTF8('Duplicated [%] name',[aName]) else
raise ESynException.CreateUTF8(ExceptionMsg,ExceptionArgs);
end;
function TDynArrayHashed.FindHashedAndFill(var ElemToFill): integer;
begin
result := fHash.FindOrNew(fHash.HashOne(@ElemtoFill),@ElemToFill);
if result<0 then
result := -1 else
ElemCopy(PAnsiChar(Value^)[cardinal(result)*ElemSize],ElemToFill);
end;
procedure TDynArrayHashed.SetEventHash(const event: TEventDynArrayHashOne);
begin
fHash.SetEventHash(event);
end;
function TDynArrayHashed.FindHashedAndUpdate(const Elem; AddIfNotExisting: boolean): integer;
var hc: cardinal;
label doh;
begin
if canHash in fHash.State then begin
doh:hc := fHash.HashOne(@Elem);
result := fHash.FindOrNew(hc,@Elem);
if (result<0) and AddIfNotExisting then begin
fHash.HashAdd(hc,result); // ReHash only if necessary
SetCount(result+1); // add new item
end;
end else begin
result := fHash.Scan(@Elem);
if result<0 then begin
if AddIfNotExisting then
if canHash in fHash.State then // Scan triggered ReHash
goto doh else begin
result := Add(Elem); // regular Add
exit;
end;
end;
end;
if result>=0 then
ElemCopy(Elem,PAnsiChar(Value^)[cardinal(result)*ElemSize]); // update
end;
function TDynArrayHashed.FindHashedAndDelete(const Elem; FillDeleted: pointer;
noDeleteEntry: boolean): integer;
begin
result := fHash.FindBeforeDelete(@Elem);
if result>=0 then begin
if FillDeleted<>nil then
ElemCopyAt(result,FillDeleted^);
if not noDeleteEntry then
Delete(result);
end;
end;
function TDynArrayHashed.GetHashFromIndex(aIndex: PtrInt): Cardinal;
begin
result := fHash.GetHashFromIndex(aIndex);
end;
function TDynArrayHashed.ReHash(forAdd: boolean): integer;
begin
result := fHash.ReHash(forAdd);
end;
function DynArray(aTypeInfo: pointer; var aValue; aCountPointer: PInteger): TDynArray;
begin
result.Init(aTypeInfo,aValue,aCountPointer);
end;
function SimpleDynArrayLoadFrom(Source: PAnsiChar; aTypeInfo: pointer;
var Count, ElemSize: integer; NoHash32Check: boolean): pointer;
var Hash: PCardinalArray absolute Source;
info: PTypeInfo;
begin
result := nil;
info := GetTypeInfo(aTypeInfo,tkDynArray);
if info=nil then
exit; // invalid type information
ElemSize := info^.elSize {$ifdef FPC}and $7FFFFFFF{$endif};
if (info^.ElType<>nil) or (Source=nil) or
(Source[0]<>AnsiChar(ElemSize)) or (Source[1]<>#0) then
exit; // invalid type information or Source content
inc(Source,2);
Count := FromVarUInt32(PByte(Source)); // dynamic array count
if (Count<>0) and (NoHash32Check or (Hash32(@Hash[1],Count*ElemSize)=Hash[0])) then
result := @Hash[1]; // returns valid Source content
end;
function IntegerDynArrayLoadFrom(Source: PAnsiChar; var Count: integer;
NoHash32Check: boolean): PIntegerArray;
var Hash: PCardinalArray absolute Source;
begin
result := nil;
if (Source=nil) or (Source[0]<>#4) or (Source[1]<>#0) then
exit; // invalid Source content
inc(Source,2);
Count := FromVarUInt32(PByte(Source)); // dynamic array count
if (Count<>0) and (NoHash32Check or (Hash32(@Hash[1],Count*4)=Hash[0])) then
result := @Hash[1]; // returns valid Source content
end;
function RawUTF8DynArrayLoadFromContains(Source: PAnsiChar;
Value: PUTF8Char; ValueLen: PtrInt; CaseSensitive: boolean): PtrInt;
var Count, Len: PtrInt;
begin
if (Value=nil) or (ValueLen=0) or
(Source=nil) or (Source[0]<>AnsiChar(SizeOf(PtrInt)))
{$ifndef FPC}or (Source[1]<>AnsiChar(tkLString)){$endif} then begin
result := -1;
exit; // invalid Source or Value content
end;
inc(Source,2);
Count := FromVarUInt32(PByte(Source)); // dynamic array count
inc(Source,SizeOf(cardinal)); // ignore Hash32 security checksum
for result := 0 to Count-1 do begin
Len := FromVarUInt32(PByte(Source));
if CaseSensitive then begin
if (Len=ValueLen) and CompareMemFixed(Value,Source,Len) then
exit;
end else
if UTF8ILComp(Value,pointer(Source),ValueLen,Len)=0 then
exit;
inc(Source,Len);
end;
result := -1;
end;
{ TObjectDynArrayWrapper }
constructor TObjectDynArrayWrapper.Create(var aValue; aOwnObjects: boolean);
begin
fValue := @aValue;
fOwnObjects := aOwnObjects;
end;
destructor TObjectDynArrayWrapper.Destroy;
begin
Clear;
inherited;
end;
function TObjectDynArrayWrapper.Find(Instance: TObject): integer;
var P: PObjectArray;
begin
P := fValue^;
if P<>nil then
for result := 0 to fCount-1 do
if P[result]=Instance then
exit;
result := -1;
end;
function TObjectDynArrayWrapper.Add(Instance: TObject): integer;
var cap: integer;
begin
cap := length(TObjectDynArray(fValue^));
if cap<=fCount then
SetLength(TObjectDynArray(fValue^),NextGrow(cap));
result := fCount;
TObjectDynArray(fValue^)[result] := Instance;
inc(fCount);
end;
procedure TObjectDynArrayWrapper.Delete(Index: integer);
var P: PObjectArray;
begin
P := fValue^;
if (P=nil) or (cardinal(Index)>=cardinal(fCount)) then
exit; // avoid Out of range
if fOwnObjects then
P[Index].Free;
dec(fCount);
if fCount>Index then
MoveFast(P[Index+1],P[Index],(fCount-Index)*SizeOf(pointer));
end;
procedure TObjectDynArrayWrapper.Clear;
var i: PtrInt;
P: PObjectArray;
begin
P := fValue^;
if P<>nil then begin
if fOwnObjects then
for i := fCount-1 downto 0 do
try
P[i].Free;
except
on Exception do;
end;
TObjectDynArray(fValue^) := nil; // set capacity to 0
fCount := 0;
end else
if fCount>0 then
raise ESynException.Create('You MUST define your IObjectDynArray field '+
'BEFORE the corresponding dynamic array');
end;
procedure TObjectDynArrayWrapper.Slice;
begin
SetLength(TObjectDynArray(fValue^),fCount);
end;
function TObjectDynArrayWrapper.Count: integer;
begin
result := fCount;
end;
function TObjectDynArrayWrapper.Capacity: integer;
begin
result := length(TObjectDynArray(fValue^));
end;
procedure TObjectDynArrayWrapper.Sort(Compare: TDynArraySortCompare);
begin
if (@Compare<>nil) and (fCount>0) then
QuickSortPtr(0,fCount-1,Compare,fValue^);
end;
function NewSynLocker: PSynLocker;
begin
result := AllocMem(SizeOf(result^));
result^.Init;
end;
function PtrArrayAdd(var aPtrArray; aItem: pointer): integer;
var a: TPointerDynArray absolute aPtrArray;
begin
result := length(a);
SetLength(a,result+1);
a[result] := aItem;
end;
function PtrArrayAddOnce(var aPtrArray; aItem: pointer): integer;
var a: TPointerDynArray absolute aPtrArray;
n: integer;
begin
n := length(a);
result := PtrUIntScanIndex(pointer(a),n,PtrUInt(aItem));
if result>=0 then
exit;
SetLength(a,n+1);
a[n] := aItem;
result := n;
end;
procedure PtrArrayDelete(var aPtrArray; aIndex: integer; aCount: PInteger);
var a: TPointerDynArray absolute aPtrArray;
n: integer;
begin
if aCount=nil then
n := length(a) else
n := aCount^;
if cardinal(aIndex)>=cardinal(n) then
exit; // out of range
dec(n);
if n>aIndex then
MoveFast(a[aIndex+1],a[aIndex],(n-aIndex)*SizeOf(pointer));
if aCount=nil then
SetLength(a,n) else
aCount^ := n;
end;
function PtrArrayDelete(var aPtrArray; aItem: pointer; aCount: PInteger): integer;
var a: TPointerDynArray absolute aPtrArray;
n: integer;
begin
if aCount=nil then
n := length(a) else
n := aCount^;
result := PtrUIntScanIndex(pointer(a),n,PtrUInt(aItem));
if result<0 then
exit;
dec(n);
if n>result then
MoveFast(a[result+1],a[result],(n-result)*SizeOf(pointer));
if aCount=nil then
SetLength(a,n) else
aCount^ := n;
end;
function PtrArrayFind(var aPtrArray; aItem: pointer): integer;
var a: TPointerDynArray absolute aPtrArray;
begin
result := PtrUIntScanIndex(pointer(a),length(a),PtrUInt(aItem));
end;
{ wrapper functions to T*ObjArr types }
function ObjArrayAdd(var aObjArray; aItem: TObject): PtrInt;
var a: TObjectDynArray absolute aObjArray;
begin
result := length(a);
SetLength(a,result+1);
a[result] := aItem;
end;
function ObjArrayAddFrom(var aDestObjArray; const aSourceObjArray): PtrInt;
var n: PtrInt;
s: TObjectDynArray absolute aSourceObjArray;
d: TObjectDynArray absolute aDestObjArray;
begin
result := length(d);
n := length(s);
SetLength(d,result+n);
MoveFast(s[0],d[result],n*SizeOf(pointer));
inc(result,n);
end;
function ObjArrayAppend(var aDestObjArray, aSourceObjArray): PtrInt;
begin
result := ObjArrayAddFrom(aDestObjArray,aSourceObjArray);
TObjectDynArray(aSourceObjArray) := nil; // aSourceObjArray[] changed ownership
end;
function ObjArrayAddCount(var aObjArray; aItem: TObject; var aObjArrayCount: integer): PtrInt;
var a: TObjectDynArray absolute aObjArray;
begin
result := aObjArrayCount;
if result=length(a) then
SetLength(a,NextGrow(result));
a[result] := aItem;
inc(aObjArrayCount);
end;
procedure ObjArrayAddOnce(var aObjArray; aItem: TObject);
var a: TObjectDynArray absolute aObjArray;
n: PtrInt;
begin
n := length(a);
if not PtrUIntScanExists(pointer(a),n,PtrUInt(aItem)) then begin
SetLength(a,n+1);
a[n] := aItem;
end;
end;
function ObjArrayAddOnceFrom(var aDestObjArray; const aSourceObjArray): PtrInt;
var n, i: PtrInt;
s: TObjectDynArray absolute aSourceObjArray;
d: TObjectDynArray absolute aDestObjArray;
begin
result := length(d);
n := length(s);
if n=0 then
exit;
SetLength(d,result+n);
for i := 0 to n-1 do
if not PtrUIntScanExists(pointer(d),result,PtrUInt(s[i])) then begin
d[result] := s[i];
inc(result);
end;
if result<>length(d) then
SetLength(d,result);
end;
procedure ObjArraySetLength(var aObjArray; aLength: integer);
begin
SetLength(TObjectDynArray(aObjArray),aLength);
end;
function ObjArrayFind(const aObjArray; aItem: TObject): PtrInt;
begin
result := PtrUIntScanIndex(pointer(aObjArray),
length(TObjectDynArray(aObjArray)),PtrUInt(aItem));
end;
function ObjArrayFind(const aObjArray; aCount: integer; aItem: TObject): PtrInt;
begin
result := PtrUIntScanIndex(pointer(aObjArray),aCount,PtrUInt(aItem));
end;
function ObjArrayCount(const aObjArray): integer;
var i: PtrInt;
a: TObjectDynArray absolute aObjArray;
begin
result := 0;
for i := 0 to length(a)-1 do
if a[i]<>nil then
inc(result);
end;
procedure ObjArrayDelete(var aObjArray; aItemIndex: PtrInt;
aContinueOnException: boolean; aCount: PInteger);
var n: PtrInt;
a: TObjectDynArray absolute aObjArray;
begin
if aCount=nil then
n := length(a) else
n := aCount^;
if cardinal(aItemIndex)>=cardinal(n) then
exit; // out of range
if aContinueOnException then
try
a[aItemIndex].Free;
except
end else
a[aItemIndex].Free;
dec(n);
if n>aItemIndex then
MoveFast(a[aItemIndex+1],a[aItemIndex],(n-aItemIndex)*SizeOf(TObject));
if aCount=nil then
SetLength(a,n) else
aCount^ := n;
end;
function ObjArrayDelete(var aObjArray; aItem: TObject): PtrInt;
begin
result := PtrUIntScanIndex(pointer(aObjArray),
length(TObjectDynArray(aObjArray)),PtrUInt(aItem));
if result>=0 then
ObjArrayDelete(aObjArray,result);
end;
function ObjArrayDelete(var aObjArray; aCount: integer; aItem: TObject): PtrInt; overload;
begin
result := PtrUIntScanIndex(pointer(aObjArray),aCount,PtrUInt(aItem));
if result>=0 then
ObjArrayDelete(aObjArray,result,false,@aCount);
end;
procedure ObjArraySort(var aObjArray; Compare: TDynArraySortCompare);
begin
if @Compare<>nil then
QuickSortPtr(0,length(TObjectDynArray(aObjArray))-1,Compare,pointer(aObjArray));
end;
procedure RawObjectsClear(o: PObject; n: integer);
var obj: TObject;
begin
if n>0 then
repeat
obj := o^;
if obj<>nil then begin // inlined FreeAndNil(o^)
o^ := nil;
obj.Destroy;
end;
inc(o);
dec(n);
until n=0;
end;
procedure ObjArrayClear(var aObjArray);
var a: TObjectDynArray absolute aObjArray;
begin
if a=nil then
exit;
RawObjectsClear(pointer(aObjArray),length(a));
a := nil;
end;
procedure ObjArrayClear(var aObjArray; aCount: integer);
var a: TObjectDynArray absolute aObjArray;
n: integer;
begin
n := length(a);
if n=0 then
exit;
if n>aCount then
aCount := n;
RawObjectsClear(pointer(aObjArray),aCount);
a := nil;
end;
procedure ObjArrayClear(var aObjArray; aContinueOnException: boolean;
aCount: PInteger);
var n,i: PtrInt;
a: TObjectDynArray absolute aObjArray;
begin
if aCount=nil then
n := length(a) else begin
n := aCount^;
aCount^ := 0;
end;
if n=0 then
exit;
if aContinueOnException then
for i := 0 to n-1 do
try
a[i].Free;
except
end
else
RawObjectsClear(pointer(a),n);
a := nil;
end;
function ObjArrayToJSON(const aObjArray; aOptions: TTextWriterWriteObjectOptions): RawUTF8;
var temp: TTextWriterStackBuffer;
begin
with DefaultTextWriterSerializer.CreateOwnedStream(temp) do
try
if woEnumSetsAsText in aOptions then
CustomOptions := CustomOptions+[twoEnumSetsAsTextInRecord];
AddObjArrayJSON(aObjArray,aOptions);
SetText(result);
finally
Free;
end;
end;
procedure ObjArrayObjArrayClear(var aObjArray);
var i: PtrInt;
a: TPointerDynArray absolute aObjArray;
begin
if a<>nil then begin
for i := 0 to length(a)-1 do
ObjArrayClear(a[i]);
a := nil;
end;
end;
procedure ObjArraysClear(const aObjArray: array of pointer);
var i: PtrInt;
begin
for i := 0 to high(aObjArray) do
if aObjArray[i]<>nil then
ObjArrayClear(aObjArray[i]^);
end;
{$ifndef DELPHI5OROLDER}
function InterfaceArrayAdd(var aInterfaceArray; const aItem: IUnknown): PtrInt;
var a: TInterfaceDynArray absolute aInterfaceArray;
begin
result := length(a);
SetLength(a,result+1);
a[result] := aItem;
end;
procedure InterfaceArrayAddOnce(var aInterfaceArray; const aItem: IUnknown);
var a: TInterfaceDynArray absolute aInterfaceArray;
n: PtrInt;
begin
if PtrUIntScanExists(pointer(aInterfaceArray),
length(TInterfaceDynArray(aInterfaceArray)),PtrUInt(aItem)) then
exit;
n := length(a);
SetLength(a,n+1);
a[n] := aItem;
end;
function InterfaceArrayFind(const aInterfaceArray; const aItem: IUnknown): PtrInt;
begin
result := PtrUIntScanIndex(pointer(aInterfaceArray),
length(TInterfaceDynArray(aInterfaceArray)),PtrUInt(aItem));
end;
procedure InterfaceArrayDelete(var aInterfaceArray; aItemIndex: PtrInt);
var n: PtrInt;
a: TInterfaceDynArray absolute aInterfaceArray;
begin
n := length(a);
if PtrUInt(aItemIndex)>=PtrUInt(n) then
exit; // out of range
a[aItemIndex] := nil;
dec(n);
if n>aItemIndex then
MoveFast(a[aItemIndex+1],a[aItemIndex],(n-aItemIndex)*SizeOf(IInterface));
TPointerDynArray(aInterfaceArray)[n] := nil; // avoid GPF in SetLength()
SetLength(a,n);
end;
function InterfaceArrayDelete(var aInterfaceArray; const aItem: IUnknown): PtrInt;
begin
result := InterfaceArrayFind(aInterfaceArray,aItem);
if result>=0 then
InterfaceArrayDelete(aInterfaceArray,result);
end;
{$endif DELPHI5OROLDER}
{ TInterfacedObjectWithCustomCreate }
constructor TInterfacedObjectWithCustomCreate.Create;
begin // nothing to do by default - overridden constructor may add custom code
end;
procedure TInterfacedObjectWithCustomCreate.RefCountUpdate(Release: boolean);
begin
if Release then
_Release else
_AddRef;
end;
{ TAutoLock }
type
/// used by TAutoLocker.ProtectMethod and TSynLocker.ProtectMethod
TAutoLock = class(TInterfacedObject)
protected
fLock: PSynLocker;
public
constructor Create(aLock: PSynLocker);
destructor Destroy; override;
end;
constructor TAutoLock.Create(aLock: PSynLocker);
begin
fLock := aLock;
fLock^.Lock;
end;
destructor TAutoLock.Destroy;
begin
fLock^.UnLock;
end;
{ TSynLocker }
const
SYNLOCKER_VTYPENOCLEAR = [varEmpty..varDate,varBoolean,
varShortInt..varWord64,varUnknown];
procedure TSynLocker.Init;
begin
fLockCount := 0;
PaddingUsedCount := 0;
InitializeCriticalSection(fSection);
fInitialized := true;
end;
procedure TSynLocker.Done;
var i: PtrInt;
begin
for i := 0 to PaddingUsedCount-1 do
if not(integer(Padding[i].VType) in SYNLOCKER_VTYPENOCLEAR) then
VarClear(variant(Padding[i]));
DeleteCriticalSection(fSection);
fInitialized := false;
end;
procedure TSynLocker.DoneAndFreeMem;
begin
Done;
FreeMem(@self);
end;
function TSynLocker.GetIsLocked: boolean;
begin
result := fLockCount <> 0;
end;
procedure TSynLocker.Lock;
begin
EnterCriticalSection(fSection);
inc(fLockCount);
end;
procedure TSynLocker.UnLock;
begin
dec(fLockCount);
LeaveCriticalSection(fSection);
end;
function TSynLocker.TryLock: boolean;
begin
result := TryEnterCriticalSection(fSection){$ifdef LINUX}{$ifdef FPC}<>0{$endif}{$endif};
if result then
inc(fLockCount);
end;
function TSynLocker.TryLockMS(retryms: integer): boolean;
begin
repeat
result := TryLock;
if result or (retryms <= 0) then
break;
SleepHiRes(1);
dec(retryms);
until false;
end;
function TSynLocker.ProtectMethod: IUnknown;
begin
result := TAutoLock.Create(@self);
end;
{$ifndef NOVARIANTS}
function TSynLocker.GetVariant(Index: integer): Variant;
begin
if cardinal(Index)<cardinal(PaddingUsedCount) then
try
Lock;
result := variant(Padding[Index]);
finally
UnLock;
end else
VarClear(result);
end;
procedure TSynLocker.SetVariant(Index: integer; const Value: Variant);
begin
if cardinal(Index)<=high(Padding) then
try
Lock;
if Index>=PaddingUsedCount then
PaddingUsedCount := Index+1;
variant(Padding[Index]) := Value;
finally
UnLock;
end;
end;
function TSynLocker.GetInt64(Index: integer): Int64;
begin
if cardinal(Index)<cardinal(PaddingUsedCount) then
try
Lock;
if not VariantToInt64(variant(Padding[index]),result) then
result := 0;
finally
UnLock;
end else
result := 0;
end;
procedure TSynLocker.SetInt64(Index: integer; const Value: Int64);
begin
SetVariant(Index,Value);
end;
function TSynLocker.GetBool(Index: integer): boolean;
begin
if cardinal(Index)<cardinal(PaddingUsedCount) then
try
Lock;
if not VariantToBoolean(variant(Padding[index]),result) then
result := false;
finally
UnLock;
end else
result := false;
end;
procedure TSynLocker.SetBool(Index: integer; const Value: boolean);
begin
SetVariant(Index,Value);
end;
function TSynLocker.GetUnLockedInt64(Index: integer): Int64;
begin
if (cardinal(Index)>=cardinal(PaddingUsedCount)) or
not VariantToInt64(variant(Padding[index]),result) then
result := 0;
end;
procedure TSynLocker.SetUnlockedInt64(Index: integer; const Value: Int64);
begin
if cardinal(Index)<=high(Padding) then begin
if Index>=PaddingUsedCount then
PaddingUsedCount := Index+1;
variant(Padding[Index]) := Value;
end;
end;
function TSynLocker.GetPointer(Index: integer): Pointer;
begin
if cardinal(Index)<cardinal(PaddingUsedCount) then
try
Lock;
with Padding[index] do
if VType=varUnknown then
result := VUnknown else
result := nil;
finally
UnLock;
end else
result := nil;
end;
procedure TSynLocker.SetPointer(Index: integer; const Value: Pointer);
begin
if cardinal(Index)<=high(Padding) then
try
Lock;
if Index>=PaddingUsedCount then
PaddingUsedCount := Index+1;
with Padding[index] do begin
if not(integer(VType) in SYNLOCKER_VTYPENOCLEAR) then
VarClear(PVariant(@VType)^);
VType := varUnknown;
VUnknown := Value;
end;
finally
UnLock;
end;
end;
function TSynLocker.GetUTF8(Index: integer): RawUTF8;
var wasString: Boolean;
begin
if cardinal(Index)<cardinal(PaddingUsedCount) then
try
Lock;
VariantToUTF8(variant(Padding[Index]),result,wasString);
if not wasString then
result := '';
finally
UnLock;
end else
result := '';
end;
procedure TSynLocker.SetUTF8(Index: integer; const Value: RawUTF8);
begin
if cardinal(Index)<=high(Padding) then
try
Lock;
if Index>=PaddingUsedCount then
PaddingUsedCount := Index+1;
RawUTF8ToVariant(Value,Padding[Index],varString);
finally
UnLock;
end;
end;
function TSynLocker.LockedInt64Increment(Index: integer; const Increment: Int64): Int64;
begin
if cardinal(Index)<=high(Padding) then
try
Lock;
result := 0;
if Index<PaddingUsedCount then
VariantToInt64(variant(Padding[index]),result) else
PaddingUsedCount := Index+1;
variant(Padding[Index]) := Int64(result+Increment);
finally
UnLock;
end else
result := 0;
end;
function TSynLocker.LockedExchange(Index: integer; const Value: Variant): Variant;
begin
if cardinal(Index)<=high(Padding) then
try
Lock;
with Padding[index] do begin
if Index<PaddingUsedCount then
result := PVariant(@VType)^ else begin
PaddingUsedCount := Index+1;
VarClear(result);
end;
PVariant(@VType)^ := Value;
end;
finally
UnLock;
end else
VarClear(result);
end;
function TSynLocker.LockedPointerExchange(Index: integer; Value: pointer): pointer;
begin
if cardinal(Index)<=high(Padding) then
try
Lock;
with Padding[index] do begin
if Index<PaddingUsedCount then
if VType=varUnknown then
result := VUnknown else begin
VarClear(PVariant(@VType)^);
result := nil;
end else begin
PaddingUsedCount := Index+1;
result := nil;
end;
VType := varUnknown;
VUnknown := Value;
end;
finally
UnLock;
end else
result := nil;
end;
{$endif NOVARIANTS}
{ TInterfacedObjectLocked }
constructor TInterfacedObjectLocked.Create;
begin
inherited Create;
fSafe := NewSynLocker;
end;
destructor TInterfacedObjectLocked.Destroy;
begin
inherited Destroy;
fSafe^.DoneAndFreeMem;
end;
{ TPersistentWithCustomCreate }
constructor TPersistentWithCustomCreate.Create;
begin // nothing to do by default - overridden constructor may add custom code
end;
{ TSynPersistent }
constructor TSynPersistent.Create;
begin // nothing to do by default - overridden constructor may add custom code
end;
procedure TSynPersistent.AssignError(Source: TSynPersistent);
var SourceName: string;
begin
if Source <> nil then
SourceName := Source.ClassName else
SourceName := 'nil';
raise EConvertError.CreateFmt('Cannot assign a %s to a %s', [SourceName, ClassName]);
end;
procedure TSynPersistent.AssignTo(Dest: TSynPersistent);
begin
Dest.AssignError(Self);
end;
procedure TSynPersistent.Assign(Source: TSynPersistent);
begin
if Source<>nil then
Source.AssignTo(Self) else
AssignError(nil);
end;
{$ifdef FPC_OR_PUREPASCAL}
class function TSynPersistent.NewInstance: TObject;
begin // bypass vmtIntfTable and vmt^.vInitTable (FPC management operators)
{$ifdef FPC_X64MM}
result := _AllocMem(InstanceSize);
{$else}
GetMem(pointer(result),InstanceSize); // InstanceSize is inlined
FillCharFast(pointer(result)^,InstanceSize,0);
{$endif}
PPointer(result)^ := pointer(self); // store VMT
end; // no benefit of rewriting FreeInstance/CleanupInstance
{$else}
class function TSynPersistent.NewInstance: TObject;
asm
push eax // class
mov eax, [eax].vmtInstanceSize
push eax // size
call System.@GetMem
pop edx // size
push eax // self
mov cl, 0
call dword ptr[FillcharFast]
pop eax // self
pop edx // class
mov [eax], edx // store VMT
end; // TSynPersistent has no interface -> bypass vmtIntfTable
procedure TSynPersistent.FreeInstance;
asm
push ebx
mov ebx, eax
@loop: mov ebx, [ebx] // handle three VMT levels per iteration
mov edx, [ebx].vmtInitTable
mov ebx, [ebx].vmtParent
test edx, edx
jnz @clr
test ebx, ebx
jz @end
mov ebx, [ebx]
mov edx, [ebx].vmtInitTable
mov ebx, [ebx].vmtParent
test edx, edx
jnz @clr
test ebx, ebx
jz @end
mov ebx, [ebx]
mov edx, [ebx].vmtInitTable
mov ebx, [ebx].vmtParent
test edx, edx
jnz @clr
test ebx, ebx
jnz @loop
@end: pop ebx
jmp System.@FreeMem
// TSynPersistent has no TMonitor -> bypass TMonitor.Destroy(self)
// BTW, TMonitor.Destroy is private, so unreachable
@clr: push offset @loop // parent has never any vmtInitTable -> @loop
jmp RecordClear // eax=self edx=typeinfo
end;
{$endif FPC_OR_PUREPASCAL}
{ TSynPersistentLock }
constructor TSynPersistentLock.Create;
begin
inherited Create;
fSafe := NewSynLocker;
end;
destructor TSynPersistentLock.Destroy;
begin
inherited Destroy;
fSafe^.DoneAndFreeMem;
end;
{ TSynList }
function TSynList.Add(item: pointer): integer;
begin
result := ObjArrayAddCount(fList,item,fCount);
end;
procedure TSynList.Clear;
begin
fList := nil;
fCount := 0;
end;
procedure TSynList.Delete(index: integer);
begin
PtrArrayDelete(fList,index,@fCount);
if (fCount>64) and (length(fList)>fCount*2) then
SetLength(fList,fCount); // reduce capacity when half list is void
end;
function TSynList.Exists(item: pointer): boolean;
begin
result := PtrUIntScanExists(pointer(fList),fCount,PtrUInt(item));
end;
function TSynList.Get(index: Integer): pointer;
begin
if cardinal(index)<cardinal(fCount) then
result := fList[index] else
result := nil;
end;
function TSynList.IndexOf(item: pointer): integer;
begin
result := PtrUIntScanIndex(pointer(fList),fCount,PtrUInt(item));
end;
function TSynList.Remove(item: Pointer): integer;
begin
result := PtrUIntScanIndex(pointer(fList),fCount,PtrUInt(item));
if result>=0 then
Delete(result);
end;
{ TSynObjectList }
constructor TSynObjectList.Create(aOwnObjects: boolean);
begin
fOwnObjects := aOwnObjects;
inherited Create;
end;
procedure TSynObjectList.Delete(index: integer);
begin
if cardinal(index)>=cardinal(fCount) then
exit;
if fOwnObjects then
TObject(fList[index]).Free;
inherited Delete(index);
end;
procedure TSynObjectList.Clear;
begin
if fOwnObjects then
RawObjectsClear(pointer(fList),fCount);
inherited Clear;
end;
procedure TSynObjectList.ClearFromLast;
var i: PtrInt;
begin
if fOwnObjects then
for i := fCount-1 downto 0 do
TObject(fList[i]).Free;
inherited Clear;
end;
destructor TSynObjectList.Destroy;
begin
Clear;
inherited Destroy;
end;
{ TSynObjectListLocked }
constructor TSynObjectListLocked.Create(AOwnsObjects: Boolean);
begin
inherited Create(AOwnsObjects);
fSafe.Init;
end;
destructor TSynObjectListLocked.Destroy;
begin
inherited Destroy;
fSafe.Done;
end;
function TSynObjectListLocked.Add(item: pointer): integer;
begin
Safe.Lock;
try
result := inherited Add(item);
finally
Safe.UnLock;
end;
end;
function TSynObjectListLocked.Remove(item: pointer): integer;
begin
Safe.Lock;
try
result := inherited Remove(item);
finally
Safe.UnLock;
end;
end;
function TSynObjectListLocked.Exists(item: pointer): boolean;
begin
Safe.Lock;
try
result := inherited Exists(item);
finally
Safe.UnLock;
end;
end;
procedure TSynObjectListLocked.Clear;
begin
Safe.Lock;
try
inherited Clear;
finally
Safe.UnLock;
end;
end;
procedure TSynObjectListLocked.ClearFromLast;
begin
Safe.Lock;
try
inherited ClearFromLast;
finally
Safe.UnLock;
end;
end;
{ ****************** text buffer and JSON functions and classes ********* }
{ TTextWriter }
procedure TTextWriter.Add(c: AnsiChar);
begin
if B>=BEnd then
FlushToStream;
inc(B);
B^ := c;
end;
procedure TTextWriter.AddOnce(c: AnsiChar);
begin
if (B>=fTempBuf) and (B^=c) then
exit; // no duplicate
if B>=BEnd then
FlushToStream;
inc(B);
B^ := c;
end;
procedure TTextWriter.Add(c1, c2: AnsiChar);
begin
if BEnd-B<=1 then
FlushToStream;
B[1] := c1;
B[2] := c2;
inc(B,2);
end;
procedure TTextWriter.CancelLastChar;
begin
if B>=fTempBuf then // Add() methods append at B+1
dec(B);
end;
function TTextWriter.LastChar: AnsiChar;
begin
if B>=fTempBuf then
result := B^ else
result := #0;
end;
procedure TTextWriter.CancelLastChar(aCharToCancel: AnsiChar);
begin
if (B>=fTempBuf) and (B^=aCharToCancel) then
dec(B);
end;
function TTextWriter.PendingBytes: PtrUInt;
begin
result := B-fTempBuf+1;
end;
procedure TTextWriter.CancelLastComma;
begin
if (B>=fTempBuf) and (B^=',') then
dec(B);
end;
procedure TTextWriter.Add(Value: PtrInt);
var tmp: array[0..23] of AnsiChar;
P: PAnsiChar;
Len: PtrInt;
begin
if BEnd-B<=24 then
FlushToStream;
if PtrUInt(Value)<=high(SmallUInt32UTF8) then begin
P := pointer(SmallUInt32UTF8[Value]);
Len := PStrLen(P-_STRLEN)^;
end else begin
P := StrInt32(@tmp[23],value);
Len := @tmp[23]-P;
end;
MoveSmall(P,B+1,Len);
inc(B,Len);
end;
{$ifndef CPU64} // Add(Value: PtrInt) already implemented it
procedure TTextWriter.Add(Value: Int64);
var tmp: array[0..23] of AnsiChar;
P: PAnsiChar;
Len: integer;
begin
if BEnd-B<=24 then
FlushToStream;
if Value<0 then begin
P := StrUInt64(@tmp[23],-Value)-1;
P^ := '-';
Len := @tmp[23]-P;
end else
if Value<=high(SmallUInt32UTF8) then begin
P := pointer(SmallUInt32UTF8[Value]);
Len := PStrLen(P-_STRLEN)^;
end else begin
P := StrUInt64(@tmp[23],Value);
Len := @tmp[23]-P;
end;
MoveSmall(P,B+1,Len);
inc(B,Len);
end;
{$endif CPU64}
procedure TTextWriter.AddCurr64(const Value: Int64);
var tmp: array[0..31] of AnsiChar;
P: PAnsiChar;
Len: PtrInt;
begin
if BEnd-B<=31 then
FlushToStream;
P := StrCurr64(@tmp[31],Value);
Len := @tmp[31]-P;
if Len>4 then
if P[Len-1]='0' then
if P[Len-2]='0' then
if P[Len-3]='0' then
if P[Len-4]='0' then
dec(Len,5) else
dec(Len,3) else
dec(Len,2) else
dec(Len);
MoveSmall(P,B+1,Len);
inc(B,Len);
end;
procedure TTextWriter.AddCurr64(const Value: currency);
begin
AddCurr64(PInt64(@Value)^);
end;
procedure TTextWriter.AddTimeLog(Value: PInt64);
begin
if BEnd-B<=31 then
FlushToStream;
inc(B,PTimeLogBits(Value)^.Text(B+1,true,'T'));
end;
procedure TTextWriter.AddUnixTime(Value: PInt64);
begin // inlined UnixTimeToDateTime()
AddDateTime(Value^/SecsPerDay+UnixDateDelta);
end;
procedure TTextWriter.AddUnixMSTime(Value: PInt64; WithMS: boolean);
begin // inlined UnixMSTimeToDateTime()
AddDateTime(Value^/MSecsPerDay+UnixDateDelta,WithMS);
end;
procedure TTextWriter.AddDateTime(Value: PDateTime; FirstChar: AnsiChar;
QuoteChar: AnsiChar; WithMS: boolean);
begin
if (Value^=0) and (QuoteChar=#0) then
exit;
if BEnd-B<=26 then
FlushToStream;
inc(B);
if QuoteChar<>#0 then
B^ := QuoteChar else
dec(B);
if Value^<>0 then begin
inc(B);
if trunc(Value^)<>0 then
B := DateToIso8601PChar(Value^,B,true);
if frac(Value^)<>0 then
B := TimeToIso8601PChar(Value^,B,true,FirstChar,WithMS);
dec(B);
end;
if twoDateTimeWithZ in fCustomOptions then begin
inc(B);
B^ := 'Z';
end;
if QuoteChar<>#0 then begin
inc(B);
B^ := QuoteChar;
end;
end;
procedure TTextWriter.AddDateTime(const Value: TDateTime; WithMS: boolean);
begin
if Value=0 then
exit;
if BEnd-B<=24 then
FlushToStream;
inc(B);
if trunc(Value)<>0 then
B := DateToIso8601PChar(Value,B,true);
if frac(Value)<>0 then
B := TimeToIso8601PChar(Value,B,true,'T',WithMS);
if twoDateTimeWithZ in fCustomOptions then
B^ := 'Z' else
dec(B);
end;
procedure TTextWriter.AddDateTimeMS(const Value: TDateTime; Expanded: boolean;
FirstTimeChar: AnsiChar; const TZD: RawUTF8);
var T: TSynSystemTime;
begin
if Value=0 then
exit;
T.FromDateTime(Value);
Add(DTMS_FMT[Expanded], [UInt4DigitsToShort(T.Year),
UInt2DigitsToShortFast(T.Month),UInt2DigitsToShortFast(T.Day),FirstTimeChar,
UInt2DigitsToShortFast(T.Hour),UInt2DigitsToShortFast(T.Minute),
UInt2DigitsToShortFast(T.Second),UInt3DigitsToShort(T.MilliSecond),TZD]);
end;
procedure TTextWriter.AddU(Value: cardinal);
var tmp: array[0..23] of AnsiChar;
P: PAnsiChar;
Len: PtrInt;
begin
if BEnd-B<=24 then
FlushToStream;
if Value<=high(SmallUInt32UTF8) then begin
P := pointer(SmallUInt32UTF8[Value]);
Len := PStrLen(P-_STRLEN)^;
end else begin
P := StrUInt32(@tmp[23],Value);
Len := @tmp[23]-P;
end;
MoveSmall(P,B+1,Len);
inc(B,Len);
end;
procedure TTextWriter.AddQ(Value: QWord);
var tmp: array[0..23] of AnsiChar;
V: Int64Rec absolute Value;
P: PAnsiChar;
Len: PtrInt;
begin
if BEnd-B<=32 then
FlushToStream;
if (V.Hi=0) and (V.Lo<=high(SmallUInt32UTF8)) then begin
P := pointer(SmallUInt32UTF8[V.Lo]);
Len := PStrLen(P-_STRLEN)^;
end else begin
P := StrUInt64(@tmp[23],Value);
Len := @tmp[23]-P;
end;
MoveSmall(P,B+1,Len);
inc(B,Len);
end;
procedure TTextWriter.AddQHex(Value: QWord);
begin
AddBinToHexDisplayQuoted(@Value,SizeOf(Value));
end;
procedure TTextWriter.Add(Value: Extended; precision: integer; noexp: boolean);
var tmp: ShortString;
begin
AddShort(ExtendedToJSON(tmp,Value,precision,noexp)^);
end;
procedure TTextWriter.AddDouble(Value: double; noexp: boolean);
var tmp: ShortString;
begin
AddShort(DoubleToJSON(tmp,Value,noexp)^);
end;
procedure TTextWriter.AddSingle(Value: single; noexp: boolean);
var tmp: ShortString;
begin
AddShort(ExtendedToJSON(tmp,Value,SINGLE_PRECISION,noexp)^);
end;
procedure TTextWriter.Add(Value: boolean);
var PS: PShortString;
begin
if Value then // normalize: boolean may not be in the expected [0,1] range
PS := @BOOL_STR[true] else
PS := @BOOL_STR[false];
AddShort(PS^);
end;
procedure TTextWriter.AddFloatStr(P: PUTF8Char);
begin
if StrLen(P)>127 then
exit; // clearly invalid input
if BEnd-B<=127 then
FlushToStream;
inc(B);
if P<>nil then
B := FloatStrCopy(P,B)-1 else
B^ := '0';
end;
procedure TTextWriter.Add({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID);
begin
if BEnd-B<=36 then
FlushToStream;
GUIDToText(B+1,@guid);
inc(B,36);
end;
procedure TTextWriter.AddCR;
begin
if BEnd-B<=1 then
FlushToStream;
PWord(B+1)^ := 13+10 shl 8; // CR + LF
inc(B,2);
end;
procedure TTextWriter.AddCRAndIndent;
var ntabs: cardinal;
begin
if B^=#9 then
exit; // we most probably just added an indentation level
ntabs := fHumanReadableLevel;
if ntabs>=cardinal(fTempBufSize) then
exit; // avoid buffer overflow
if BEnd-B<=Integer(ntabs)+1 then
FlushToStream;
PWord(B+1)^ := 13+10 shl 8; // CR + LF
FillCharFast(B[3],ntabs,9); // #9=tab
inc(B,ntabs+2);
end;
procedure TTextWriter.AddChars(aChar: AnsiChar; aCount: integer);
var n: integer;
begin
repeat
n := BEnd-B;
if aCount<n then
n := aCount else
FlushToStream; // loop to avoid buffer overflow
FillCharFast(B[1],n,ord(aChar));
inc(B,n);
dec(aCount,n);
until aCount<=0;
end;
procedure TTextWriter.Add2(Value: PtrUInt);
begin
if BEnd-B<=3 then
FlushToStream;
if Value>99 then
PCardinal(B+1)^ := $3030+ord(',')shl 16 else // '00,' if overflow
PCardinal(B+1)^ := TwoDigitLookupW[Value]+ord(',')shl 16;
inc(B,3);
end;
procedure TTextWriter.Add4(Value: PtrUInt);
begin
if BEnd-B<=5 then
FlushToStream;
if Value>9999 then
PCardinal(B+1)^ := $30303030 else // '0000,' if overflow
YearToPChar(Value,B+1);
inc(B,5);
B^ := ',';
end;
procedure TTextWriter.AddCurrentLogTime(LocalTime: boolean);
var time: TSynSystemTime;
begin
FromGlobalTime(LocalTime,time);
time.AddLogTime(self);
end;
procedure TTextWriter.AddCurrentNCSALogTime(LocalTime: boolean);
var time: TSynSystemTime;
begin
FromGlobalTime(LocalTime,time);
if BEnd-B<=21 then
FlushToStream;
inc(B,time.ToNCSAText(B+1));
end;
function Value3Digits(V: PtrUInt; P: PUTF8Char; W: PWordArray): PtrUInt;
{$ifdef HASINLINE}inline;{$endif}
begin
result := V div 100;
PWord(P+1)^ := W[V-result*100];
V := result;
result := result div 10;
P^ := AnsiChar(V-result*10+48);
end;
procedure TTextWriter.AddMicroSec(MS: cardinal);
var W: PWordArray;
begin // in 00.000.000 TSynLog format
if BEnd-B<=17 then
FlushToStream;
B[3] := '.';
B[7] := '.';
inc(B);
W := @TwoDigitLookupW;
MS := Value3Digits(Value3Digits(MS,B+7,W),B+3,W);
if MS>99 then
MS := 99;
PWord(B)^:= W[MS];
inc(B,9);
end;
procedure TTextWriter.Add3(Value: PtrUInt);
var V: PtrUInt;
begin
if BEnd-B<=4 then
FlushToStream;
if Value>999 then
PCardinal(B+1)^ := $303030 else begin// '0000,' if overflow
V := Value div 10;
PCardinal(B+1)^ := TwoDigitLookupW[V]+(Value-V*10+48)shl 16;
end;
inc(B,4);
B^ := ',';
end;
procedure TTextWriter.AddCSVInteger(const Integers: array of Integer);
var i: PtrInt;
begin
if length(Integers)=0 then
exit;
for i := 0 to high(Integers) do begin
Add(Integers[i]);
Add(',');
end;
CancelLastComma;
end;
procedure TTextWriter.AddCSVDouble(const Doubles: array of double);
var i: PtrInt;
begin
if length(Doubles)=0 then
exit;
for i := 0 to high(Doubles) do begin
AddDouble(Doubles[i]);
Add(',');
end;
CancelLastComma;
end;
procedure TTextWriter.AddCSVUTF8(const Values: array of RawUTF8);
var i: PtrInt;
begin
if length(Values)=0 then
exit;
for i := 0 to high(Values) do begin
Add('"');
AddJSONEscape(pointer(Values[i]));
Add('"',',');
end;
CancelLastComma;
end;
procedure TTextWriter.AddCSVConst(const Values: array of const);
var i: PtrInt;
begin
if length(Values)=0 then
exit;
for i := 0 to high(Values) do begin
AddJSONEscape(Values[i]);
Add(',');
end;
CancelLastComma;
end;
procedure TTextWriter.Add(const Values: array of const);
var i: PtrInt;
begin
for i := 0 to high(Values) do
AddJSONEscape(Values[i]);
end;
procedure TTextWriter.WriteObject(Value: TObject; Options: TTextWriterWriteObjectOptions);
var i: PtrInt;
begin
if Value<>nil then
if Value.InheritsFrom(Exception) then
Add('{"%":"%"}',[Value.ClassType,Exception(Value).Message]) else
if Value.InheritsFrom(TRawUTF8List) then
with TRawUTF8List(Value) do begin
self.Add('[');
for i := 0 to fCount-1 do begin
self.Add('"');
self.AddJSONEscape(pointer(fValue[i]));
self.Add('"',',');
end;
self.CancelLastComma;
self.Add(']');
exit;
end else
if Value.InheritsFrom(TStrings) then
with TStrings(Value) do begin
self.Add('[');
for i := 0 to Count-1 do begin
self.Add('"');
{$ifdef UNICODE}
self.AddJSONEscapeW(pointer(Strings[i]),Length(Strings[i]));
{$else}
self.AddJSONEscapeAnsiString(Strings[i]);
{$endif}
self.Add('"',',');
end;
self.CancelLastComma;
self.Add(']');
exit;
end else
if not(woFullExpand in Options) or
not(Value.InheritsFrom(TList)
{$ifndef LVCL} or Value.InheritsFrom(TCollection){$endif}) then
Value := nil;
if Value=nil then begin
AddShort('null');
exit;
end;
Add('{');
AddInstanceName(Value,':');
Add('[');
if Value.InheritsFrom(TList) then
for i := 0 to TList(Value).Count-1 do
AddInstanceName(TList(Value).List[i],',')
{$ifndef LVCL} else
if Value.InheritsFrom(TCollection) then
for i := 0 to TCollection(Value).Count-1 do
AddInstanceName(TCollection(Value).Items[i],',') {$endif} ;
CancelLastComma;
Add(']','}');
end;
function TTextWriter.InternalJSONWriter: TTextWriter;
begin
if fInternalJSONWriter=nil then
fInternalJSONWriter := DefaultTextWriterSerializer.CreateOwnedStream else
fInternalJSONWriter.CancelAll;
result := fInternalJSONWriter;
end;
procedure TTextWriter.AddJSONEscape(Source: TTextWriter);
begin
if Source.fTotalFileSize=0 then
AddJSONEscape(Source.fTempBuf,Source.B-Source.fTempBuf+1) else
AddJSONEscape(Pointer(Source.Text));
end;
procedure TTextWriter.AddNoJSONEscape(Source: TTextWriter);
begin
if Source.fTotalFileSize=0 then
AddNoJSONEscape(Source.fTempBuf,Source.B-Source.fTempBuf+1) else
AddNoJSONEscapeUTF8(Source.Text);
end;
procedure TTextWriter.AddRawJSON(const json: RawJSON);
begin
if json='' then
AddShort('null') else
AddNoJSONEscape(pointer(json),length(json));
end;
procedure TTextWriter.WriteObjectAsString(Value: TObject;
Options: TTextWriterWriteObjectOptions);
begin
Add('"');
InternalJSONWriter.WriteObject(Value,Options);
AddJSONEscape(fInternalJSONWriter);
Add('"');
end;
class procedure TTextWriter.RegisterCustomJSONSerializer(aTypeInfo: pointer;
aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter);
begin
GlobalJSONCustomParsers.RegisterCallbacks(aTypeInfo,aReader,aWriter);
end;
class procedure TTextWriter.UnRegisterCustomJSONSerializer(aTypeInfo: pointer);
begin
GlobalJSONCustomParsers.RegisterCallbacks(aTypeInfo,nil,nil);
end;
class function TTextWriter.GetCustomJSONParser(var DynArray: TDynArray;
out CustomReader: TDynArrayJSONCustomReader;
out CustomWriter: TDynArrayJSONCustomWriter): boolean;
begin
result := DynArray.HasCustomJSONParser; // use var above since may set fParser
if result then
with GlobalJSONCustomParsers.fParser[DynArray.fParser] do begin
CustomReader := Reader;
CustomWriter := Writer;
end;
end;
{$ifndef NOVARIANTS}
class procedure TTextWriter.RegisterCustomJSONSerializerForVariant(
aClass: TCustomVariantType; aReader: TDynArrayJSONCustomReader;
aWriter: TDynArrayJSONCustomWriter);
begin // here we register TCustomVariantTypeClass info instead of TypeInfo()
GlobalJSONCustomParsers.RegisterCallbacksVariant(aClass,aReader,aWriter);
end;
class procedure TTextWriter.RegisterCustomJSONSerializerForVariantByType(aVarType: TVarType;
aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter);
var aClass: TCustomVariantType;
begin
if FindCustomVariantType(aVarType,aClass) then
RegisterCustomJSONSerializerForVariant(aClass,aReader,aWriter);
end;
{$endif NOVARIANTS}
class function TTextWriter.RegisterCustomJSONSerializerFromText(aTypeInfo: pointer;
const aRTTIDefinition: RawUTF8): TJSONRecordAbstract;
begin
result := GlobalJSONCustomParsers.RegisterFromText(aTypeInfo,aRTTIDefinition);
end;
class procedure TTextWriter.RegisterCustomJSONSerializerFromText(
const aTypeInfoTextDefinitionPairs: array of const);
var n,i: integer;
def: RawUTF8;
begin
n := length(aTypeInfoTextDefinitionPairs);
if (n=0) or (n and 1=1) then
exit;
n := n shr 1;
if n=0 then
exit;
for i := 0 to n-1 do
if (aTypeInfoTextDefinitionPairs[i*2].VType<>vtPointer) or
not VarRecToUTF8IsString(aTypeInfoTextDefinitionPairs[i*2+1],def) then
raise ESynException.Create('RegisterCustomJSONSerializerFromText[?]') else
GlobalJSONCustomParsers.RegisterFromText(
aTypeInfoTextDefinitionPairs[i*2].VPointer,def);
end;
class function TTextWriter.RegisterCustomJSONSerializerSetOptions(aTypeInfo: pointer;
aOptions: TJSONCustomParserSerializationOptions; aAddIfNotExisting: boolean): boolean;
var ndx: integer;
begin
result := false;
if aTypeInfo=nil then
exit;
case PTypeKind(aTypeInfo)^ of
tkRecord{$ifdef FPC},tkObject{$endif}:
ndx := GlobalJSONCustomParsers.RecordSearch(aTypeInfo,aAddIfNotExisting);
tkDynArray:
ndx := GlobalJSONCustomParsers.DynArraySearch(aTypeInfo,nil,aAddIfNotExisting);
else
exit;
end;
if (ndx>=0) and
(GlobalJSONCustomParsers.fParser[ndx].RecordCustomParser<>nil) then begin
GlobalJSONCustomParsers.fParser[ndx].RecordCustomParser.Options := aOptions;
result := true;
end;
end;
class function TTextWriter.RegisterCustomJSONSerializerSetOptions(
const aTypeInfo: array of pointer; aOptions: TJSONCustomParserSerializationOptions;
aAddIfNotExisting: boolean): boolean;
var i: integer;
begin
result := true;
for i := 0 to high(aTypeInfo) do
if not RegisterCustomJSONSerializerSetOptions(aTypeInfo[i],aOptions,aAddIfNotExisting) then
result := false;
end;
class function TTextWriter.RegisterCustomJSONSerializerFindParser(
aTypeInfo: pointer; aAddIfNotExisting: boolean): TJSONRecordAbstract;
var ndx: integer;
begin
result := nil;
if aTypeInfo=nil then
exit;
case PTypeKind(aTypeInfo)^ of
tkRecord{$ifdef FPC},tkObject{$endif}:
ndx := GlobalJSONCustomParsers.RecordSearch(aTypeInfo,aAddIfNotExisting);
tkDynArray:
ndx := GlobalJSONCustomParsers.DynArraySearch(aTypeInfo,nil,aAddIfNotExisting);
else
exit;
end;
if ndx>=0 then
result := GlobalJSONCustomParsers.fParser[ndx].RecordCustomParser;
end;
class procedure TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType(
aTypeInfo: pointer; const aTypeName: RawUTF8);
begin
JSONSerializerFromTextSimpleTypeAdd(aTypeName,aTypeInfo,0,0);
end;
class procedure TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType(
const aTypeInfos: array of pointer);
var i: integer;
begin
for i := 0 to high(aTypeInfos) do
RegisterCustomJSONSerializerFromTextSimpleType(aTypeInfos[i],'');
end;
class procedure TTextWriter.RegisterCustomJSONSerializerFromTextBinaryType(
aTypeInfo: pointer; aDataSize, aFieldSize: integer);
begin
JSONSerializerFromTextSimpleTypeAdd('',aTypeInfo,aDataSize,aFieldSize);
end;
class procedure TTextWriter.RegisterCustomJSONSerializerFromTextBinaryType(
const aTypeInfoDataFieldSize: array of const);
var n,i: integer;
s1,s2: Int64;
begin
n := length(aTypeInfoDataFieldSize);
if n mod 3=0 then
for i := 0 to (n div 3)-1 do
if (aTypeInfoDataFieldSize[i*3].VType<>vtPointer) or
not VarRecToInt64(aTypeInfoDataFieldSize[i*3+1],s1) or
not VarRecToInt64(aTypeInfoDataFieldSize[i*3+2],s2) then
raise ESynException.CreateUTF8('RegisterCustomJSONSerializerFromTextBinaryType[%]',[i]) else
JSONSerializerFromTextSimpleTypeAdd('',aTypeInfoDataFieldSize[i*3].VPointer,s1,s2);
end;
procedure TTextWriter.AddRecordJSON(const Rec; TypeInfo: pointer);
var customWriter: TDynArrayJSONCustomWriter;
begin
if (self=nil) or (@Rec=nil) or (TypeInfo=nil) or
not(PTypeKind(TypeInfo)^ in tkRecordTypes) then
raise ESynException.CreateUTF8('Invalid %.AddRecordJSON(%)',[self,TypeInfo]);
if GlobalJSONCustomParsers.RecordSearch(TypeInfo,customWriter,nil) then
customWriter(self,Rec) else
WrRecord(Rec,TypeInfo);
end;
procedure TTextWriter.AddVoidRecordJSON(TypeInfo: pointer);
var tmp: TBytes;
info: PTypeInfo;
begin
info := GetTypeInfo(TypeInfo,tkRecordKinds);
if (self=nil) or (info=nil) then
raise ESynException.CreateUTF8('Invalid %.AddVoidRecordJSON(%)',[self,TypeInfo]);
SetLength(tmp,info^.recSize {$ifdef FPC}and $7FFFFFFF{$endif});
AddRecordJSON(tmp[0],TypeInfo);
end;
{$ifndef NOVARIANTS}
procedure TTextWriter.AddVariant(const Value: variant; Escape: TTextWriterKind);
var CustomVariantType: TCustomVariantType;
vt: cardinal;
begin
vt := TVarData(Value).VType;
with TVarData(Value) do
case vt of
varEmpty,
varNull: AddShort('null');
varSmallint: Add(VSmallint);
varShortInt: Add(VShortInt);
varByte: AddU(VByte);
varWord: AddU(VWord);
varLongWord: AddU(VLongWord);
varInteger: Add(VInteger);
varInt64: Add(VInt64);
varWord64: AddQ(VInt64);
varSingle: AddSingle(VSingle);
varDouble: AddDouble(VDouble);
varDate: AddDateTime(@VDate,'T','"');
varCurrency: AddCurr64(VInt64);
varBoolean: Add(VBoolean); // 'true'/'false'
varVariant: AddVariant(PVariant(VPointer)^,Escape);
varString: begin
if Escape=twJSONEscape then
Add('"');
{$ifdef HASCODEPAGE}
AddAnyAnsiString(RawByteString(VString),Escape);
{$else} // VString is expected to be a RawUTF8
Add(VString,length(RawUTF8(VString)),Escape);
{$endif}
if Escape=twJSONEscape then
Add('"');
end;
varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: begin
if Escape=twJSONEscape then
Add('"');
AddW(VAny,0,Escape);
if Escape=twJSONEscape then
Add('"');
end;
else
if vt=varVariant or varByRef then
AddVariant(PVariant(VPointer)^,Escape) else
if vt=varByRef or varString then begin
if Escape=twJSONEscape then
Add('"');
{$ifdef HASCODEPAGE}
AddAnyAnsiString(PRawByteString(VAny)^,Escape);
{$else} // VString is expected to be a RawUTF8
Add(PPointer(VAny)^,length(PRawUTF8(VAny)^),Escape);
{$endif}
if Escape=twJSONEscape then
Add('"');
end else
if {$ifdef HASVARUSTRING}(vt=varByRef or varUString) or {$endif}
(vt=varByRef or varOleStr) then begin
if Escape=twJSONEscape then
Add('"');
AddW(PPointer(VAny)^,0,Escape);
if Escape=twJSONEscape then
Add('"');
end else
if FindCustomVariantType(vt,CustomVariantType) then
if CustomVariantType.InheritsFrom(TSynInvokeableVariantType) then
TSynInvokeableVariantType(CustomVariantType).ToJson(self,Value,Escape) else
GlobalJSONCustomParsers.VariantWrite(CustomVariantType,self,Value,Escape) else
raise ESynException.CreateUTF8('%.AddVariant VType=%',[self,vt]);
end;
end;
{$endif NOVARIANTS}
procedure TTextWriter.AddDynArrayJSON(var aDynArray: TDynArrayHashed);
begin
AddDynArrayJson(PDynArray(@aDynArray)^);
end;
procedure TTextWriter.AddDynArrayJSON(aTypeInfo: pointer; const aValue);
var DynArray: TDynArray;
begin
DynArray.Init(aTypeInfo,pointer(@aValue)^);
AddDynArrayJSON(DynArray);
end;
procedure TTextWriter.AddDynArrayJSONAsString(aTypeInfo: pointer; var aValue);
begin
Add('"');
InternalJSONWriter.AddDynArrayJSON(aTypeInfo,aValue);
AddJSONEscape(fInternalJSONWriter);
Add('"');
end;
procedure TTextWriter.AddObjArrayJSON(const aObjArray; aOptions: TTextWriterWriteObjectOptions);
var i: integer;
a: TObjectDynArray absolute aObjArray;
begin
Add('[');
for i := 0 to length(a)-1 do begin
WriteObject(a[i],aOptions);
Add(',');
end;
CancelLastComma;
Add(']');
end;
procedure TTextWriter.AddTypedJSON(aTypeInfo: pointer; const aValue);
var max, i: Integer;
PS: PShortString;
customWriter: TDynArrayJSONCustomWriter;
DynArray: TDynArray;
procedure AddPS; overload;
begin
Add('"');
if twoTrimLeftEnumSets in fCustomOptions then
AddTrimLeftLowerCase(PS) else
AddShort(PS^);
Add('"');
end;
procedure AddPS(bool: boolean); overload;
begin
AddPS;
Add(':');
Add(bool);
end;
begin
case PTypeKind(aTypeInfo)^ of
tkClass:
WriteObject(TObject(aValue),[woFullExpand]);
tkEnumeration:
if twoEnumSetsAsBooleanInRecord in fCustomOptions then begin
PS := GetEnumName(aTypeInfo,byte(aValue));
AddPS(true);
end else
if twoEnumSetsAsTextInRecord in fCustomOptions then begin
PS := GetEnumName(aTypeInfo,byte(aValue));
AddPS;
end else
AddU(byte(aValue));
tkSet:
if GetSetInfo(aTypeInfo,max,PS) then
if twoEnumSetsAsBooleanInRecord in fCustomOptions then begin
Add('{');
for i := 0 to max do begin
AddPS(GetBitPtr(@aValue,i));
Add(',');
inc(PByte(PS),PByte(PS)^+1); // next
end;
CancelLastComma;
Add('}');
end else
if twoEnumSetsAsTextInRecord in fCustomOptions then begin
Add('[');
if (twoFullSetsAsStar in fCustomOptions) and
GetAllBits(cardinal(aValue),max+1) then
AddShort('"*"') else begin
for i := 0 to max do begin
if GetBitPtr(@aValue,i) then begin
AddPS;
Add(',');
end;
inc(PByte(PS),PByte(PS)^+1); // next
end;
CancelLastComma;
end;
Add(']');
end else
if max<8 then
AddU(byte(aValue)) else
if max<16 then
AddU(word(aValue)) else
if max<32 then
AddU(cardinal(aValue)) else
Add(Int64(aValue))
else AddShort('null');
tkRecord{$ifdef FPC},tkObject{$endif}: // inlined AddRecordJSON()
if GlobalJSONCustomParsers.RecordSearch(aTypeInfo,customWriter,nil) then
customWriter(self,aValue) else
WrRecord(aValue,aTypeInfo);
tkDynArray: begin
DynArray.Init(aTypeInfo,(@aValue)^);
AddDynArrayJSON(DynArray);
end;
{$ifndef NOVARIANTS}
tkVariant:
AddVariant(variant(aValue),twJSONEscape);
{$endif}
else
AddShort('null');
end;
end;
function TTextWriter.AddJSONReformat(JSON: PUTF8Char;
Format: TTextWriterJSONFormat; EndOfObject: PUTF8Char): PUTF8Char;
var objEnd: AnsiChar;
Name,Value: PUTF8Char;
NameLen,ValueLen: integer;
begin
result := nil;
if JSON=nil then
exit;
while (JSON^<=' ') and (JSON^<>#0) do inc(JSON);
case JSON^ of
'[': begin // array
repeat inc(JSON) until (JSON^=#0) or (JSON^>' ');
if JSON^=']' then begin
Add('[');
inc(JSON);
end else begin
if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then
AddCRAndIndent;
inc(fHumanReadableLevel);
Add('[');
repeat
if JSON=nil then
exit;
if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then
AddCRAndIndent;
JSON := AddJSONReformat(JSON,Format,@objEnd);
if objEnd=']' then
break;
Add(objEnd);
until false;
dec(fHumanReadableLevel);
if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then
AddCRAndIndent;
end;
Add(']');
end;
'{': begin // object
repeat inc(JSON) until (JSON^=#0) or (JSON^>' ');
Add('{');
inc(fHumanReadableLevel);
if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then
AddCRAndIndent;
if JSON^='}' then
repeat inc(JSON) until (JSON^=#0) or (JSON^>' ') else
repeat
Name := GetJSONPropName(JSON,@NameLen);
if Name=nil then
exit;
if (Format in [jsonUnquotedPropName,jsonUnquotedPropNameCompact]) and
JsonPropNameValid(Name) then
AddNoJSONEscape(Name,NameLen) else begin
Add('"');
AddJSONEscape(Name);
Add('"');
end;
if Format in [jsonCompact,jsonUnquotedPropNameCompact] then
Add(':') else
Add(':',' ');
while (JSON^<=' ') and (JSON^<>#0) do inc(JSON);
JSON := AddJSONReformat(JSON,Format,@objEnd);
if objEnd='}' then
break;
Add(objEnd);
if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then
AddCRAndIndent;
until false;
dec(fHumanReadableLevel);
if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then
AddCRAndIndent;
Add('}');
end;
'"': begin // string
Value := JSON;
JSON := GotoEndOfJSONString(JSON);
if JSON^<>'"' then
exit;
inc(JSON);
AddNoJSONEscape(Value,JSON-Value);
end;
else begin // numeric or true/false/null
Value := GetJSONField(JSON,result,nil,EndOfObject,@ValueLen); // let wasString=nil
if Value=nil then
AddShort('null') else begin
while (ValueLen>0) and (Value[ValueLen-1]<=' ') do dec(ValueLen);
AddNoJSONEscape(Value,ValueLen);
end;
exit;
end;
end;
if JSON<>nil then begin
while (JSON^<=' ') and (JSON^<>#0) do inc(JSON);
if EndOfObject<>nil then
EndOfObject^ := JSON^;
if JSON^<>#0 then
repeat inc(JSON) until (JSON^=#0) or (JSON^>' ');
end;
result := JSON;
end;
function TTextWriter.AddJSONToXML(JSON: PUTF8Char; ArrayName,EndOfObject: PUTF8Char): PUTF8Char;
var objEnd: AnsiChar;
Name,Value: PUTF8Char;
n,c: integer;
begin
result := nil;
if JSON=nil then
exit;
while (JSON^<=' ') and (JSON^<>#0) do inc(JSON);
case JSON^ of
'[': begin
repeat inc(JSON) until (JSON^=#0) or (JSON^>' ');
if JSON^=']' then
JSON := GotoNextNotSpace(JSON+1) else begin
n := 0;
repeat
if JSON=nil then
exit;
Add('<');
if ArrayName=nil then
Add(n) else
AddXmlEscape(ArrayName);
Add('>');
JSON := AddJSONToXML(JSON,nil,@objEnd);
Add('<','/');
if ArrayName=nil then
Add(n) else
AddXmlEscape(ArrayName);
Add('>');
inc(n);
until objEnd=']';
end;
end;
'{': begin
repeat inc(JSON) until (JSON^=#0) or (JSON^>' ');
if JSON^='}' then
repeat inc(JSON) until (JSON^=#0) or (JSON^>' ') else begin
repeat
Name := GetJSONPropName(JSON);
if Name=nil then
exit;
while (JSON^<=' ') and (JSON^<>#0) do inc(JSON);
if JSON^='[' then // arrays are written as list of items, without root
JSON := AddJSONToXML(JSON,Name,@objEnd) else begin
Add('<');
AddXmlEscape(Name);
Add('>');
JSON := AddJSONToXML(JSON,Name,@objEnd);
Add('<','/');
AddXmlEscape(Name);
Add('>');
end;
until objEnd='}';
end;
end;
else begin
Value := GetJSONField(JSON,result,nil,EndOfObject); // let wasString=nil
if Value=nil then
AddShort('null') else begin
c := PInteger(Value)^ and $ffffff;
if (c=JSON_BASE64_MAGIC) or (c=JSON_SQLDATE_MAGIC) then
inc(Value,3); // just ignore the Magic codepoint encoded as UTF-8
AddXmlEscape(Value);
end;
exit;
end;
end;
if JSON<>nil then begin
while (JSON^<=' ') and (JSON^<>#0) do inc(JSON);
if EndOfObject<>nil then
EndOfObject^ := JSON^;
if JSON^<>#0 then
repeat inc(JSON) until (JSON^=#0) or (JSON^>' ');
end;
result := JSON;
end;
procedure TTextWriter.AddDynArrayJSON(var aDynArray: TDynArray);
var i,n: PtrInt;
P: Pointer;
T: TDynArrayKind;
tmp: RawByteString;
customWriter: TDynArrayJSONCustomWriter;
customParser: TJSONRecordAbstract;
nested: TDynArray;
hr: boolean;
begin // code below must match TDynArray.LoadFromJSON
n := aDynArray.Count-1;
if n<0 then begin
Add('[',']');
exit;
end;
if aDynArray.HasCustomJSONParser then
with GlobalJSONCustomParsers.fParser[aDynArray.fParser] do begin
customWriter := Writer;
customParser := RecordCustomParser;
end else begin
customWriter := nil;
customParser := nil;
end;
if Assigned(customWriter) then
T := djCustom else
T := aDynArray.GuessKnownType({exacttype=}true);
P := aDynArray.fValue^;
Add('[');
case T of
djNone:
if (aDynArray.ElemType<>nil) and
(PTypeKind(aDynArray.ElemType)^=tkDynArray) then begin
for i := 0 to n do begin
nested.Init(aDynArray.ElemType,P^);
AddDynArrayJSON(nested);
Add(',');
inc(PByte(P),aDynArray.ElemSize);
end;
end else begin
tmp := aDynArray.SaveTo;
WrBase64(pointer(tmp),length(tmp),{withMagic=}true);
end;
djCustom: begin
if customParser=nil then
hr := false else
hr := soWriteHumanReadable in customParser.Options;
if hr then
Inc(fHumanReadableLevel);
for i := 0 to n do begin
customWriter(self,P^);
Add(',');
inc(PByte(P),aDynArray.ElemSize);
end;
if hr then begin
dec(fHumanReadableLevel);
CancelLastComma;
AddCRAndIndent;
end;
end;
{$ifndef NOVARIANTS}
djVariant:
for i := 0 to n do begin
AddVariant(PVariantArray(P)^[i],twJSONEscape);
Add(',');
end;
{$endif}
djRawUTF8:
for i := 0 to n do begin
Add('"');
AddJSONEscape(PPointerArray(P)^[i]);
Add('"',',');
end;
djRawByteString:
for i := 0 to n do begin
WrBase64(PPointerArray(P)^[i],Length(PRawByteStringArray(P)^[i]),{withMagic=}true);
Add(',');
end;
djInteger:
for i := 0 to n do begin
Add(PIntegerArray(P)^[i]);
Add(',');
end;
djInt64:
for i := 0 to n do begin
Add(PInt64Array(P)^[i]);
Add(',');
end;
djQWord:
for i := 0 to n do begin
AddQ(PQwordArray(P)^[i]);
Add(',');
end;
else // slightly less efficient for less-used types
if T in DJ_STRING then
for i := 0 to n do begin
Add('"');
case T of
djTimeLog: AddTimeLog(@PInt64Array(P)^[i]);
djDateTime: AddDateTime(@PDoubleArray(P)^[i],'T',#0,false);
djDateTimeMS: AddDateTime(@PDoubleArray(P)^[i],'T',#0,true);
djWideString, djSynUnicode: AddJSONEscapeW(PPointerArray(P)^[i]);
djWinAnsi: AddAnyAnsiString(PRawByteStringArray(P)^[i],twJSONEscape,CODEPAGE_US);
djString:
{$ifdef UNICODE}
AddJSONEscapeW(PPointerArray(P)^[i]);
{$else}
AddAnyAnsiString(PRawByteStringArray(P)^[i],twJSONEscape,0);
{$endif}
djHash128: AddBinToHexDisplayLower(@PHash128Array(P)[i],SizeOf(THash128));
djHash256: AddBinToHexDisplayLower(@PHash256Array(P)[i],SizeOf(THash256));
djHash512: AddBinToHexDisplayLower(@PHash512Array(P)[i],SizeOf(THash512));
djInterface: AddPointer(PPtrIntArray(P)^[i]);
else raise ESynException.CreateUTF8('AddDynArrayJSON unsupported %',[ToText(T)^]);
end;
Add('"',',');
end else
for i := 0 to n do begin
case T of
djBoolean: Add(PBooleanArray(P)^[i]);
djByte: AddU(PByteArray(P)^[i]);
djWord: AddU(PWordArray(P)^[i]);
djCardinal: AddU(PCardinalArray(P)^[i]);
djSingle: AddSingle(PSingleArray(P)^[i]);
djDouble: AddDouble(PDoubleArray(P)^[i]);
djCurrency: AddCurr64(PInt64Array(P)^[i]);
else raise ESynException.CreateUTF8('AddDynArrayJSON unsupported %',[ToText(T)^]);
end;
Add(',');
end;
end;
CancelLastComma;
Add(']');
end;
procedure TTextWriter.Add(const Format: RawUTF8; const Values: array of const;
Escape: TTextWriterKind; WriteObjectOptions: TTextWriterWriteObjectOptions);
var ValuesIndex: integer;
F: PUTF8Char;
label write;
begin // we put const char > #127 as #??? -> asiatic MBCS codepage OK
if Format='' then
exit;
if (Format='%') and (high(Values)>=0) then begin
Add(Values[0],Escape);
exit;
end;
ValuesIndex := 0;
F := pointer(Format);
repeat
repeat
case ord(F^) of
0: exit;
ord('%'): break;
{$ifdef OLDTEXTWRITERFORMAT}
164: AddCR; // currency sign -> add CR,LF
167: if B^=',' then dec(B); // section sign to ignore next comma
ord('|'): begin
inc(F); // |% -> %
goto write;
end;
ord('$'),163,181: // dollar, pound, micro sign
break; // process command value
{$endif}
else begin
write: if B>=BEnd then
FlushToStream;
B[1] := F^;
inc(B);
end;
end;
inc(F);
until false;
// add next value as text
if ValuesIndex<=high(Values) then // missing value will display nothing
case ord(F^) of
ord('%'):
Add(Values[ValuesIndex],Escape,WriteObjectOptions);
{$ifdef OLDTEXTWRITERFORMAT}
ord('$'): with Values[ValuesIndex] do
if Vtype=vtInteger then Add2(VInteger);
163: with Values[ValuesIndex] do // pound sign
if Vtype=vtInteger then Add4(VInteger);
181: with Values[ValuesIndex] do // micro sign
if Vtype=vtInteger then Add3(VInteger);
{$endif}
end;
inc(F);
inc(ValuesIndex);
until false;
end;
procedure TTextWriter.AddLine(const Text: shortstring);
var L: PtrInt;
begin
L := ord(Text[0]);
if BEnd-B<=L+2 then
FlushToStream;
inc(B);
if L>0 then begin
MoveFast(Text[1],B^,L);
inc(B,L);
end;
PWord(B)^ := 13+10 shl 8; // CR + LF
inc(B);
end;
procedure TTextWriter.AddBinToHexDisplay(Bin: pointer; BinBytes: integer);
begin
if cardinal(BinBytes*2-1)>=cardinal(fTempBufSize) then
exit;
if BEnd-B<=BinBytes*2 then
FlushToStream;
BinToHexDisplay(Bin,PAnsiChar(B+1),BinBytes);
inc(B,BinBytes*2);
end;
procedure TTextWriter.AddBinToHexDisplayLower(Bin: pointer; BinBytes: integer);
begin
if cardinal(BinBytes*2-1)>=cardinal(fTempBufSize) then
exit;
if BEnd-B<=BinBytes*2 then
FlushToStream;
BinToHexDisplayLower(Bin,PAnsiChar(B+1),BinBytes);
inc(B,BinBytes*2);
end;
procedure TTextWriter.AddBinToHexDisplayQuoted(Bin: pointer; BinBytes: integer);
begin
if cardinal(BinBytes*2+2)>=cardinal(fTempBufSize) then
exit;
if BEnd-B<=BinBytes*2+2 then
FlushToStream;
B[1] := '"';
BinToHexDisplayLower(Bin,PAnsiChar(B+2),BinBytes);
inc(B,BinBytes*2);
B[2] := '"';
inc(B,2);
end;
procedure TTextWriter.AddBinToHexDisplayMinChars(Bin: pointer; BinBytes: PtrInt);
begin
if (BinBytes<=0) or (cardinal(BinBytes*2-1)>=cardinal(fTempBufSize)) then
exit;
repeat // append hexa chars up to the last non zero byte
dec(BinBytes);
until (BinBytes=0) or (PByteArray(Bin)[BinBytes]<>0);
inc(BinBytes);
if BEnd-B<=BinBytes*2 then
FlushToStream;
BinToHexDisplayLower(Bin,PAnsiChar(B+1),BinBytes);
inc(B,BinBytes*2);
end;
procedure TTextWriter.AddPointer(P: PtrUInt);
begin
AddBinToHexDisplayMinChars(@P,SizeOf(P));
end;
procedure TTextWriter.AddBinToHex(Bin: Pointer; BinBytes: integer);
var ChunkBytes: PtrInt;
begin
if BinBytes<=0 then
exit;
if B>=BEnd then
FlushToStream;
inc(B);
repeat
// guess biggest size to be added into buf^ at once
ChunkBytes := (BEnd-B) shr 1; // div 2, *2 -> two hexa chars per byte
if BinBytes<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:
WriteToStream(fTempBuf,B-fTempBuf);
B := fTempBuf;
until false;
dec(B); // allow CancelLastChar
end;
procedure TTextWriter.AddQuotedStr(Text: PUTF8Char; Quote: AnsiChar;
TextMaxLen: PtrInt);
var BMax: PUTF8Char;
c: AnsiChar;
begin
if TextMaxLen<=0 then
TextMaxLen := maxInt else
if TextMaxLen>5 then
dec(TextMaxLen,5);
BMax := BEnd-3;
if B>=BMax then begin
FlushToStream;
BMax := BEnd-3;
end;
inc(B);
B^ := Quote;
inc(B);
if Text<>nil then
repeat
if B<BMax then begin
dec(TextMaxLen);
if TextMaxLen<>0 then begin
c := Text^;
inc(Text);
if c=#0 then
break;
B^ := c;
inc(B);
if c<>Quote then
continue;
B^ := c;
inc(B);
end else begin
PCardinal(B)^ := ord('.')+ord('.')shl 8+ord('.')shl 16;
inc(B,3);
break;
end;
end else begin
FlushToStream;
BMax := BEnd-3;
end;
until false;
B^ := Quote;
end;
const
HTML_ESC: array[hfAnyWhere..high(TTextWriterHTMLFormat)] of TSynAnsicharSet = (
[#0,'&','"','<','>'],[#0,'&','<','>'],[#0,'&','"']);
procedure TTextWriter.AddHtmlEscape(Text: PUTF8Char; Fmt: TTextWriterHTMLFormat);
var B: PUTF8Char;
esc: ^TSynAnsicharSet;
begin
if Text=nil then
exit;
if Fmt=hfNone then begin
AddNoJSONEscape(Text);
exit;
end;
esc := @HTML_ESC[Fmt];
repeat
B := Text;
while not(Text^ in esc^) do
inc(Text);
AddNoJSONEscape(B,Text-B);
case Text^ of
#0: exit;
'<': AddShort('&lt;');
'>': AddShort('&gt;');
'&': AddShort('&amp;');
'"': AddShort('&quot;');
end;
inc(Text);
until Text^=#0;
end;
procedure TTextWriter.AddHtmlEscape(Text: PUTF8Char; TextLen: PtrInt;
Fmt: TTextWriterHTMLFormat);
var B: PUTF8Char;
esc: ^TSynAnsicharSet;
begin
if (Text=nil) or (TextLen<=0) then
exit;
if Fmt=hfNone then begin
AddNoJSONEscape(Text,TextLen);
exit;
end;
inc(TextLen,PtrInt(Text)); // TextLen = final PtrInt(Text)
esc := @HTML_ESC[Fmt];
repeat
B := Text;
while (PtrInt(Text)<TextLen) and not(Text^ in esc^) do
inc(Text);
AddNoJSONEscape(B,Text-B);
if PtrInt(Text)=TextLen then
exit;
case Text^ of
#0: exit;
'<': AddShort('&lt;');
'>': AddShort('&gt;');
'&': AddShort('&amp;');
'"': AddShort('&quot;');
end;
inc(Text);
until false;
end;
procedure TTextWriter.AddHtmlEscapeString(const Text: string; Fmt: TTextWriterHTMLFormat);
begin
AddHtmlEscape(pointer(StringToUTF8(Text)),Fmt);
end;
procedure TTextWriter.AddHtmlEscapeUTF8(const Text: RawUTF8; Fmt: TTextWriterHTMLFormat);
begin
AddHtmlEscape(pointer(Text),length(Text),Fmt);
end;
procedure TTextWriter.AddXmlEscape(Text: PUTF8Char);
const XML_ESCAPE: TSynByteSet =
[0..31,ord('<'),ord('>'),ord('&'),ord('"'),ord('''')];
var i,beg: PtrInt;
begin
if Text=nil then
exit;
i := 0;
repeat
beg := i;
if not(ord(Text[i]) in XML_ESCAPE) then begin
repeat // it is faster to handle all not-escaped chars at once
inc(i);
until ord(Text[i]) in XML_ESCAPE;
AddNoJSONEscape(Text+beg,i-beg);
end;
repeat
case Text[i] of
#0: exit;
#1..#8,#11,#12,#14..#31:
; // ignore invalid character - see http://www.w3.org/TR/xml/#NT-Char
#9,#10,#13: begin // characters below ' ', #9 e.g. -> // '&#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+1)=Value);
inc(B,3);
end;
function Int18ToChars3(Value: cardinal): RawUTF8;
begin
FastSetString(result,nil,3);
PCardinal(result)^ := ((Value shr 12) and $3f)+
((Value shr 6) and $3f)shl 8+
(Value and $3f)shl 16+$202020;
end;
procedure Int18ToChars3(Value: cardinal; var result: RawUTF8);
begin
FastSetString(result,nil,3);
PCardinal(result)^ := ((Value shr 12) and $3f)+
((Value shr 6) and $3f)shl 8+
(Value and $3f)shl 16+$202020;
end;
function Chars3ToInt18(P: pointer): cardinal;
begin
result := PCardinal(P)^-$202020;
result := ((result shr 16)and $3f)+
((result shr 8) and $3f)shl 6+
(result and $3f)shl 12;
end;
procedure TTextWriter.AddNoJSONEscape(P: Pointer);
begin
AddNoJSONEscape(P,StrLen(PUTF8Char(P)));
end;
procedure TTextWriter.AddNoJSONEscape(P: Pointer; Len: PtrInt);
var i: PtrInt;
begin
if (P<>nil) and (Len>0) then begin
inc(B); // allow CancelLastChar
repeat
i := BEnd-B+1; // guess biggest size to be added into buf^ at once
if Len<i then
i := Len;
// add UTF-8 bytes
if i>0 then begin
MoveFast(P^,B^,i);
inc(B,i);
end;
if i=Len then
break;
inc(PByte(P),i);
dec(Len,i);
// FlushInc writes B-buf+1 -> special one below:
WriteToStream(fTempBuf,B-fTempBuf);
B := fTempBuf;
until false;
dec(B); // allow CancelLastChar
end;
end;
procedure TTextWriter.AddNoJSONEscapeUTF8(const text: RawByteString);
begin
AddNoJSONEscape(pointer(text),length(text));
end;
procedure TTextWriter.AddNoJSONEscapeW(WideChar: PWord; WideCharCount: integer);
var PEnd: PtrUInt;
BMax: PUTF8Char;
begin
if WideChar=nil then
exit;
BMax := BEnd-7; // ensure enough space for biggest Unicode glyph as UTF-8
if WideCharCount=0 then
repeat
if B>=BMax then begin
FlushToStream;
BMax := BEnd-7; // B may have been resized -> recompute BMax
end;
if WideChar^=0 then
break;
if WideChar^<=126 then begin
B[1] := AnsiChar(ord(WideChar^));
inc(WideChar);
inc(B);
end else
inc(B,UTF16CharToUtf8(B+1,WideChar));
until false else begin
PEnd := PtrUInt(WideChar)+PtrUInt(WideCharCount)*SizeOf(WideChar^);
repeat
if B>=BMax then begin
FlushToStream;
BMax := BEnd-7;
end;
if WideChar^=0 then
break;
if WideChar^<=126 then begin
B[1] := AnsiChar(ord(WideChar^));
inc(WideChar);
inc(B);
if PtrUInt(WideChar)<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 (L>2) and (PInteger(s)^ and $ffffff=JSON_BASE64_MAGIC) then begin
AddNoJSONEscape(pointer(s),L); // identified as a BLOB content
exit;
end;
if CodePage<0 then
{$ifdef HASCODEPAGE}
CodePage := PStrRec(PtrUInt(s)-STRRECSIZE)^.codePage;
{$else}
CodePage := 0; // TSynAnsiConvert.Engine(0)=CurrentAnsiConvert
{$endif}
AddAnyAnsiBuffer(pointer(s),L,Escape,CodePage);
end;
procedure TTextWriter.AddAnyAnsiBuffer(P: PAnsiChar; Len: PtrInt;
Escape: TTextWriterKind; CodePage: Integer);
var B: PUTF8Char;
begin
if Len>0 then
case CodePage of
CP_UTF8: // direct write of RawUTF8 content
if Escape<>twJSONEscape then
Add(PUTF8Char(P),Len,Escape) else
Add(PUTF8Char(P),0,Escape);
CP_RAWBYTESTRING:
Add(PUTF8Char(P),Len,Escape); // direct write of RawByteString content
CP_UTF16:
AddW(PWord(P),0,Escape); // direct write of UTF-16 content
CP_SQLRAWBLOB: begin
AddNoJSONEscape(@PByteArray(@JSON_BASE64_MAGIC_QUOTE_VAR)[1],3);
WrBase64(P,Len,{withMagic=}false);
end;
else begin
// first handle trailing 7 bit ASCII chars, by quad
B := pointer(P);
if Len>=4 then
repeat
if PCardinal(P)^ and $80808080<>0 then
break; // break on first non ASCII quad
inc(P,4);
dec(Len,4);
until Len<4;
if (Len>0) and (P^<#128) then
repeat
inc(P);
dec(Len);
until (Len=0) or (P^>=#127);
if P<>pointer(B) then
Add(B,P-B,Escape);
if Len=0 then
exit;
// rely on explicit conversion for all remaining ASCII characters
TSynAnsiConvert.Engine(CodePage).InternalAppendUTF8(P,Len,self,Escape);
end;
end;
end;
var
/// fast 256-byte branchless lookup table
// - 0 indicates no escape needed
// - 1 indicates #0 (end of string)
// - 2 should be escaped as \u00xx
// - b,t,n,f,r,\," as escaped character for #8,#9,#10,#12,#13,\,"
JSON_ESCAPE: TNormTableByte;
function NeedsJsonEscape(P: PUTF8Char; PLen: integer): boolean;
var tab: PNormTableByte;
begin
result := true;
tab := @JSON_ESCAPE;
if PLen>0 then
repeat
if tab[ord(P^)]<>0 then
exit;
inc(P);
dec(PLen);
until PLen=0;
result := false;
end;
function NeedsJsonEscape(const Text: RawUTF8): boolean;
begin
result := NeedsJsonEscape(pointer(Text),length(Text));
end;
function NeedsJsonEscape(P: PUTF8Char): boolean;
var tab: PNormTableByte;
esc: byte;
begin
result := false;
if P=nil then
exit;
tab := @JSON_ESCAPE;
repeat
esc := tab[ord(P^)];
if esc=0 then
inc(P) else
if esc=1 then
exit else // #0 reached
break;
until false;
result := true;
end;
procedure TTextWriter.InternalAddFixedAnsi(Source: PAnsiChar; SourceChars: Cardinal;
AnsiToWide: PWordArray; Escape: TTextWriterKind);
var c: cardinal;
esc: byte;
begin
while SourceChars>0 do begin
c := byte(Source^);
if c<=$7F then begin
if c=0 then
exit;
if B>=BEnd then
FlushToStream;
case Escape of
twNone: begin
inc(B);
B^ := AnsiChar(c);
end;
twJSONEscape: begin
esc := JSON_ESCAPE[c];
if esc=0 then begin // no escape needed
inc(B);
B^ := AnsiChar(c);
end else
if esc=1 then // #0
exit else
if esc=2 then begin // #7 e.g. -> \u0007
AddShort('\u00');
AddByteToHex(c);
end else
Add('\',AnsiChar(esc)); // escaped as \ + b,t,n,f,r,\,"
end;
twOnSameLine: begin
inc(B);
if c<32 then
B^ := ' ' else
B^ := AnsiChar(c);
end;
end
end else begin // no surrogate is expected in TSynAnsiFixedWidth charsets
if BEnd-B<=3 then
FlushToStream;
c := AnsiToWide[c]; // convert FixedAnsi char into Unicode char
if c>$7ff then begin
B[1] := AnsiChar($E0 or (c shr 12));
B[2] := AnsiChar($80 or ((c shr 6) and $3F));
B[3] := AnsiChar($80 or (c and $3F));
inc(B,3);
end else begin
B[1] := AnsiChar($C0 or (c shr 6));
B[2] := AnsiChar($80 or (c and $3F));
inc(B,2);
end;
end;
dec(SourceChars);
inc(Source);
end;
end;
procedure TTextWriter.AddOnSameLine(P: PUTF8Char);
begin
if P<>nil then
while P^<>#0 do begin
if B>=BEnd then
FlushToStream;
if P^<' ' then
B[1] := ' ' else
B[1] := P^;
inc(P);
inc(B);
end;
end;
procedure TTextWriter.AddOnSameLine(P: PUTF8Char; Len: PtrInt);
var i: PtrInt;
begin
if P<>nil then
for i := 0 to Len-1 do begin
if B>=BEnd then
FlushToStream;
if P[i]<' ' then
B[1] := ' ' else
B[1] := P[i];
inc(B);
end;
end;
procedure TTextWriter.AddOnSameLineW(P: PWord; Len: PtrInt);
var PEnd: PtrUInt;
begin
if P=nil then exit;
if Len=0 then
PEnd := 0 else
PEnd := PtrUInt(P)+PtrUInt(Len)*SizeOf(WideChar);
while (Len=0) or (PtrUInt(P)<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,start: PtrInt;
{$ifdef CPUX86NOTPIC}tab: TNormTableByte absolute JSON_ESCAPE;
{$else}tab: PNormTableByte;{$endif}
label noesc;
begin
if P=nil then
exit;
if Len=0 then
dec(Len); // -1 = no end
i := 0;
{$ifndef CPUX86NOTPIC} tab := @JSON_ESCAPE; {$endif}
if tab[PByteArray(P)[i]]=0 then begin
noesc:start := i;
if Len<0 then
repeat // fastest loop is for AddJSONEscape(P,nil)
inc(i);
until tab[PByteArray(P)[i]]<>0 else
repeat
inc(i);
until (i>=Len) or (tab[PByteArray(P)[i]]<>0);
inc(PByte(P),start);
dec(i,start);
if Len>=0 then
dec(Len,start);
if BEnd-B<=i then
AddNoJSONEscape(P,i) else begin
MoveFast(P^,B[1],i);
inc(B,i);
end;
if (Len>=0) and (i>=Len) then
exit;
end;
repeat
if BEnd-B<=10 then
FlushToStream;
case tab[PByteArray(P)[i]] of
0: goto noesc;
1: exit; // #0
2: begin // characters below ' ', #7 e.g. -> // 'u0007'
PCardinal(B+1)^ := ord('\')+ord('u')shl 8+ord('0')shl 16+ord('0')shl 24;
inc(B,4);
PWord(B+1)^ := TwoDigitsHexWB[PByteArray(P)[i]];
end;
else // escaped as \ + b,t,n,f,r,\,"
PWord(B+1)^ := (integer(tab[PByteArray(P)[i]]) shl 8) or ord('\');
end;
inc(i);
inc(B,2);
until (Len>=0) and (i>=Len);
end;
procedure TTextWriter.AddJSONEscapeW(P: PWord; Len: PtrInt);
var i,c,s: PtrInt;
esc: byte;
begin
if P=nil then
exit;
if Len=0 then
Len := MaxInt;
i := 0;
while i<Len do begin
s := i;
repeat
c := PWordArray(P)[i];
if (c<=127) and (JSON_ESCAPE[c]<>0) then
break;
inc(i);
until i>=Len;
if i<>s then
AddNoJSONEscapeW(@PWordArray(P)[s],i-s);
if i>=Len then
exit;
c := PWordArray(P)[i];
if c=0 then
exit;
esc := JSON_ESCAPE[c];
if esc=1 then // #0
exit else
if esc=2 then begin // characters below ' ', #7 e.g. -> \u0007
AddShort('\u00');
AddByteToHex(c);
end else
Add('\',AnsiChar(esc)); // escaped as \ + b,t,n,f,r,\,"
inc(i);
end;
end;
procedure TTextWriter.AddJSONEscape(const V: TVarRec);
begin
with V do
case VType of
vtPointer: AddShort('null');
vtString, vtAnsiString,{$ifdef HASVARUSTRING}vtUnicodeString,{$endif}
vtPChar, vtChar, vtWideChar, vtWideString, vtClass: begin
Add('"');
case VType of
vtString: if VString^[0]<>#0 then AddJSONEscape(@VString^[1],ord(VString^[0]));
vtAnsiString: AddJSONEscape(VAnsiString);
{$ifdef HASVARUSTRING}
vtUnicodeString: AddJSONEscapeW(
pointer(UnicodeString(VUnicodeString)),length(UnicodeString(VUnicodeString)));
{$endif}
vtPChar: AddJSONEscape(VPChar);
vtChar: AddJSONEscape(@VChar,1);
vtWideChar: AddJSONEscapeW(@VWideChar,1);
vtWideString: AddJSONEscapeW(VWideString);
vtClass: AddClassName(VClass);
end;
Add('"');
end;
vtBoolean: Add(VBoolean); // 'true'/'false'
vtInteger: Add(VInteger);
vtInt64: Add(VInt64^);
{$ifdef FPC}
vtQWord: AddQ(V.VQWord^);
{$endif}
vtExtended: AddDouble(VExtended^);
vtCurrency: AddCurr64(VInt64^);
vtObject: WriteObject(VObject);
{$ifndef NOVARIANTS}
vtVariant: AddVariant(VVariant^,twJSONEscape);
{$endif}
end;
end;
procedure TTextWriter.AddJSONString(const Text: RawUTF8);
begin
Add('"');
AddJSONEscape(pointer(Text));
Add('"');
end;
procedure TTextWriter.Add(const V: TVarRec; Escape: TTextWriterKind;
WriteObjectOptions: TTextWriterWriteObjectOptions);
begin
with V do
case VType of
vtInteger: Add(VInteger);
vtBoolean: if VBoolean then Add('1') else Add('0'); // normalize
vtChar: Add(@VChar,1,Escape);
vtExtended: AddDouble(VExtended^);
vtCurrency: AddCurr64(VInt64^);
vtInt64: Add(VInt64^);
{$ifdef FPC}
vtQWord: AddQ(VQWord^);
{$endif}
{$ifndef NOVARIANTS}
vtVariant: AddVariant(VVariant^,Escape);
{$endif}
vtString: if VString^[0]<>#0 then Add(@VString^[1],ord(VString^[0]),Escape);
vtInterface,
vtPointer: AddBinToHexDisplayMinChars(@VPointer,SizeOf(VPointer));
vtPChar: Add(PUTF8Char(VPChar),Escape);
vtObject: WriteObject(VObject,WriteObjectOptions);
vtClass: AddClassName(VClass);
vtWideChar: AddW(@VWideChar,1,Escape);
vtPWideChar:
AddW(pointer(VPWideChar),StrLenW(VPWideChar),Escape);
vtAnsiString:
if VAnsiString<>nil then
Add(VAnsiString,length(RawUTF8(VAnsiString)),Escape); // expect RawUTF8
vtWideString:
if VWideString<>nil then
AddW(VWideString,length(WideString(VWideString)),Escape);
{$ifdef HASVARUSTRING}
vtUnicodeString:
if VUnicodeString<>nil then // convert to UTF-8
AddW(VUnicodeString,length(UnicodeString(VUnicodeString)),Escape);
{$endif}
end;
end;
{$ifndef NOVARIANTS}
procedure TTextWriter.AddJSON(const Format: RawUTF8; const Args,Params: array of const);
var temp: variant;
begin
_JsonFmt(Format,Args,Params,JSON_OPTIONS_FAST,temp);
AddVariant(temp,twJSONEscape);
end;
{$endif}
procedure TTextWriter.AddJSONArraysAsJSONObject(keys,values: PUTF8Char);
var k,v: PUTF8Char;
begin
if (keys=nil) or (keys^<>'[') or (values=nil) or (values^<>'[') then begin
AddShort('null');
exit;
end;
inc(keys); // jump initial [
inc(values);
Add('{');
repeat
k := GotoEndJSONItem(keys);
v := GotoEndJSONItem(values);
if (k=nil) or (v=nil) then
break; // invalid JSON input
AddNoJSONEscape(keys,k-keys);
Add(':');
AddNoJSONEscape(values,v-values);
Add(',');
if (k^<>',') or (v^<>',') then
break; // reached the end of the input JSON arrays
keys := k+1;
values := v+1;
until false;
CancelLastComma;
Add('}');
end;
procedure TTextWriter.AddJSONEscape(const NameValuePairs: array of const);
var a: integer;
procedure WriteValue;
begin
case VarRecAsChar(NameValuePairs[a]) of
ord('['): begin
Add('[');
while a<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),0);
{$else}
AddAnsiString(s,twNone);
{$endif}
end;
procedure TTextWriter.AddJSONEscapeString(const s: string);
begin
if s<>'' then
{$ifdef UNICODE}
AddJSONEscapeW(pointer(s),Length(s));
{$else}
AddAnyAnsiString(s,twJSONEscape,0);
{$endif}
end;
procedure TTextWriter.AddJSONEscapeAnsiString(const s: AnsiString);
begin
AddAnyAnsiString(s,twJSONEscape,0);
end;
procedure TTextWriter.AddProp(PropName: PUTF8Char; PropNameLen: PtrInt);
begin
if PropNameLen=0 then
exit; // paranoid check
if BEnd-B<=PropNameLen+3 then
FlushToStream;
if twoForceJSONExtended in CustomOptions then begin
MoveSmall(PropName,B+1,PropNameLen);
inc(B,PropNameLen+1);
B^ := ':';
end else begin
B[1] := '"';
MoveSmall(PropName,B+2,PropNameLen);
inc(B,PropNameLen+2);
PWord(B)^ := ord('"')+ord(':')shl 8;
inc(B);
end;
end;
procedure TTextWriter.AddPropName(const PropName: ShortString);
begin
AddProp(@PropName[1],ord(PropName[0]));
end;
procedure TTextWriter.AddPropJSONString(const PropName: shortstring; const Text: RawUTF8);
begin
AddProp(@PropName[1],ord(PropName[0]));
AddJSONString(Text);
Add(',');
end;
procedure TTextWriter.AddPropJSONInt64(const PropName: shortstring; Value: Int64);
begin
AddProp(@PropName[1],ord(PropName[0]));
Add(Value);
Add(',');
end;
procedure TTextWriter.AddFieldName(const FieldName: RawUTF8);
begin
AddProp(Pointer(FieldName),length(FieldName));
end;
procedure TTextWriter.AddClassName(aClass: TClass);
begin
if aClass<>nil then
AddShort(PShortString(PPointer(PtrInt(PtrUInt(aClass))+vmtClassName)^)^);
end;
procedure TTextWriter.AddInstanceName(Instance: TObject; SepChar: AnsiChar);
begin
Add('"');
if Instance=nil then
AddShort('void') else
AddShort(PShortString(PPointer(PPtrInt(Instance)^+vmtClassName)^)^);
Add('(');
AddBinToHexDisplayMinChars(@Instance,SizeOf(Instance));
Add(')','"');
if SepChar<>#0 then
Add(SepChar);
end;
procedure TTextWriter.AddInstancePointer(Instance: TObject; SepChar: AnsiChar;
IncludeUnitName, IncludePointer: boolean);
var info: PTypeInfo;
begin
if IncludeUnitName then begin
info := PPointer(PPtrInt(Instance)^+vmtTypeInfo)^;
if info<>nil then begin // avoid GPF if no RTTI for this class
AddShort(PShortString(@GetTypeInfo(info)^.UnitNameLen)^);
Add('.');
end;
end;
AddShort(PShortString(PPointer(PPtrInt(Instance)^+vmtClassName)^)^);
if IncludePointer then begin
Add('(');
AddBinToHexDisplayMinChars(@Instance,SizeOf(Instance));
Add(')');
end;
if SepChar<>#0 then
Add(SepChar);
end;
procedure TTextWriter.AddShort(const Text: ShortString);
var L: PtrInt;
begin
L := ord(Text[0]);
if L=0 then
exit;
if BEnd-B<=L then
FlushToStream;
MoveFast(Text[1],B[1],L);
inc(B,L);
end;
procedure TTextWriter.AddQuotedStringAsJSON(const QuotedString: RawUTF8);
var L: integer;
P,B: PUTF8Char;
quote: AnsiChar;
begin
L := length(QuotedString);
if L>0 then begin
quote := QuotedString[1];
if (quote in ['''','"']) and (QuotedString[L]=quote) then begin
Add('"');
P := pointer(QuotedString);
inc(P);
repeat
B := P;
while P[0]<>quote do inc(P);
if P[1]<>quote then
break; // end quote
inc(P);
AddJSONEscape(B,P-B);
inc(P); // ignore double quote
until false;
if P-B<>0 then
AddJSONEscape(B,P-B);
Add('"');
end else
AddNoJSONEscape(pointer(QuotedString),length(QuotedString));
end;
end;
procedure TTextWriter.AddTrimLeftLowerCase(Text: PShortString);
var P: PAnsiChar;
L: integer;
begin
L := length(Text^);
P := @Text^[1];
while (L>0) and (P^ in ['a'..'z']) do begin
inc(P);
dec(L);
end;
if L=0 then
AddShort(Text^) else
AddNoJSONEscape(P,L);
end;
procedure TTextWriter.AddTrimSpaces(const Text: RawUTF8);
begin
AddTrimSpaces(pointer(Text));
end;
procedure TTextWriter.AddTrimSpaces(P: PUTF8Char);
var c: AnsiChar;
begin
if P<>nil then
repeat
c := P^;
inc(P);
if c>' ' then
Add(c);
until c=#0;
end;
procedure TTextWriter.AddString(const Text: RawUTF8);
var L: PtrInt;
begin
L := PtrInt(Text);
if L=0 then
exit;
L := PStrLen(L-_STRLEN)^;
if 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: PtrInt);
var L: PtrInt;
begin
L := PtrInt(Text);
if (len<=0) or (L=0) then
exit;
if start<0 then
start := 0 else
dec(start);
L := PStrLen(L-_STRLEN)^;
dec(L,start);
if L>0 then begin
if len<L then
L := len;
AddNoJSONEscape(@PByteArray(Text)[start],L);
end;
end;
procedure TTextWriter.AddStrings(const Text: array of RawUTF8);
var i: PtrInt;
begin
for i := 0 to high(Text) do
AddString(Text[i]);
end;
procedure TTextWriter.AddStrings(const Text: RawUTF8; count: integer);
var i,L: integer;
begin
L := length(Text);
if L>0 then
if L*count>fTempBufSize then
for i := 1 to count do
AddString(Text) else begin
if BEnd-B<=L*count then
FlushToStream;
for i := 1 to count do begin
MoveFast(pointer(Text)^,B[1],L);
inc(B,L);
end;
end;
end;
procedure TTextWriter.CancelAll;
begin
if self=nil then
exit; // avoid GPF
if fTotalFileSize<>0 then
fTotalFileSize := fStream.Seek(fInitialStreamPosition,soBeginning);
B := fTempBuf-1;
end;
procedure TTextWriter.SetBuffer(aBuf: pointer; aBufSize: integer);
begin
if aBufSize<=16 then
raise ESynException.CreateUTF8('%.SetBuffer(size=%)',[self,aBufSize]);
if aBuf=nil then
GetMem(fTempBuf,aBufSize) else begin
fTempBuf := aBuf;
Include(fCustomOptions,twoBufferIsExternal);
end;
fTempBufSize := aBufSize;
B := fTempBuf-1; // Add() methods will append at B+1
BEnd := fTempBuf+fTempBufSize-16; // -16 to avoid buffer overwrite/overread
if DefaultTextWriterTrimEnum then
Include(fCustomOptions,twoTrimLeftEnumSets);
end;
constructor TTextWriter.Create(aStream: TStream; aBufSize: integer);
begin
SetStream(aStream);
if aBufSize<256 then
aBufSize := 256;
SetBuffer(nil,aBufSize);
end;
constructor TTextWriter.Create(aStream: TStream; aBuf: pointer; aBufSize: integer);
begin
SetStream(aStream);
SetBuffer(aBuf,aBufSize);
end;
constructor TTextWriter.CreateOwnedStream(aBufSize: integer);
begin
Create(TRawByteStringStream.Create,aBufSize);
Include(fCustomOptions,twoStreamIsOwned);
end;
constructor TTextWriter.CreateOwnedStream(aBuf: pointer; aBufSize: integer);
begin
SetStream(TRawByteStringStream.Create);
SetBuffer(aBuf,aBufSize);
Include(fCustomOptions,twoStreamIsOwned);
end;
constructor TTextWriter.CreateOwnedStream(var aStackBuf: TTextWriterStackBuffer;
aBufSize: integer);
begin
if aBufSize>SizeOf(aStackBuf) then // too small -> allocate on heap
CreateOwnedStream(aBufSize) else
CreateOwnedStream(@aStackBuf,SizeOf(aStackBuf));
end;
constructor TTextWriter.CreateOwnedFileStream(const aFileName: TFileName;
aBufSize: integer);
begin
DeleteFile(aFileName);
Create(TFileStream.Create(aFileName,fmCreate or fmShareDenyWrite),aBufSize);
Include(fCustomOptions,twoStreamIsOwned);
end;
destructor TTextWriter.Destroy;
begin
if twoStreamIsOwned in fCustomOptions then
fStream.Free;
if not (twoBufferIsExternal in fCustomOptions) then
FreeMem(fTempBuf);
fInternalJSONWriter.Free;
inherited;
end;
class procedure TTextWriter.SetDefaultEnumTrim(aShouldTrimEnumsAsText: boolean);
begin
DefaultTextWriterTrimEnum := aShouldTrimEnumsAsText;
end;
procedure TTextWriter.SetStream(aStream: TStream);
begin
if fStream<>nil then
if twoStreamIsOwned in fCustomOptions then begin
FreeAndNil(fStream);
Exclude(fCustomOptions,twoStreamIsOwned);
end;
if aStream<>nil then begin
fStream := aStream;
fInitialStreamPosition := fStream.Seek(0,soCurrent);
fTotalFileSize := fInitialStreamPosition;
end;
end;
procedure TTextWriter.FlushToStream;
var i: PtrInt;
s: PtrUInt;
begin
i := B-fTempBuf+1;
if i<=0 then
exit;
WriteToStream(fTempBuf,i);
if not (twoFlushToStreamNoAutoResize in fCustomOptions) then begin
s := fTotalFileSize-fInitialStreamPosition;
if (fTempBufSize<49152) and (s>PtrUInt(fTempBufSize)*4) then
s := fTempBufSize*2 else // tune small (stack-alloc?) buffer
if (fTempBufSize<1 shl 20) and (s>40 shl 20) then
s := 1 shl 20 else // 40MB -> 1MB buffer
s := 0;
if s>0 then begin
fTempBufSize := s;
if twoBufferIsExternal in fCustomOptions then // use heap, not stack
exclude(fCustomOptions,twoBufferIsExternal) else
FreeMem(fTempBuf); // with big content comes bigger buffer
GetMem(fTempBuf,fTempBufSize);
BEnd := fTempBuf+(fTempBufSize-16);
end;
end;
B := fTempBuf-1;
end;
procedure TTextWriter.WriteToStream(data: pointer; len: PtrUInt);
begin
if Assigned(fOnFlushToStream) then
fOnFlushToStream(data,len);
fStream.WriteBuffer(data^,len);
inc(fTotalFileSize,len);
end;
function TTextWriter.GetTextLength: PtrUInt;
begin
if self=nil then
result := 0 else
result := PtrUInt(B-fTempBuf+1)+fTotalFileSize-fInitialStreamPosition;
end;
function TTextWriter.Text: RawUTF8;
begin
SetText(result);
end;
procedure TTextWriter.ForceContent(const text: RawUTF8);
begin
CancelAll;
if (fInitialStreamPosition=0) and fStream.InheritsFrom(TRawByteStringStream) then
TRawByteStringStream(fStream).fDataString := text else
fStream.WriteBuffer(pointer(text)^,length(text));
fTotalFileSize := fInitialStreamPosition+cardinal(length(text));
end;
procedure TTextWriter.FlushFinal;
begin
Include(fCustomOptions,twoFlushToStreamNoAutoResize);
FlushToStream;
end;
procedure TTextWriter.SetText(var result: RawUTF8; reformat: TTextWriterJSONFormat);
var Len: cardinal;
begin
FlushFinal;
Len := fTotalFileSize-fInitialStreamPosition;
if Len=0 then
result := '' else
if fStream.InheritsFrom(TRawByteStringStream) then
with TRawByteStringStream(fStream) do
if fInitialStreamPosition=0 then begin
{$ifdef HASCODEPAGE} // FPC expects this
SetCodePage(fDataString,CP_UTF8,false);
{$endif}
result := fDataString;
fDataString := '';
end else
FastSetString(result,PAnsiChar(pointer(DataString))+fInitialStreamPosition,Len) else
if fStream.InheritsFrom(TCustomMemoryStream) then
with TCustomMemoryStream(fStream) do
FastSetString(result,PAnsiChar(Memory)+fInitialStreamPosition,Len) else begin
FastSetString(result,nil,Len);
fStream.Seek(fInitialStreamPosition,soBeginning);
fStream.Read(pointer(result)^,Len);
end;
if reformat<>jsonCompact then begin // reformat using the very same instance
CancelAll;
AddJSONReformat(pointer(result),reformat,nil);
SetText(result);
end;
end;
procedure TTextWriter.WrRecord(const Rec; TypeInfo: pointer);
var L: integer;
tmp: RawByteString;
begin
L := RecordSaveLength(Rec,TypeInfo);
SetString(tmp,nil,L);
if L<>0 then
RecordSave(Rec,pointer(tmp),TypeInfo);
WrBase64(pointer(tmp),L,{withMagic=}true);
end;
procedure TTextWriter.WrBase64(P: PAnsiChar; Len: PtrUInt; withMagic: boolean);
var trailing, main, n: PtrUInt;
begin
if withMagic then
if Len<=0 then begin
AddShort('null'); // JSON null is better than "" for BLOBs
exit;
end else
AddNoJSONEscape(@JSON_BASE64_MAGIC_QUOTE_VAR,4);
if len>0 then begin
n := Len div 3;
trailing := Len-n*3;
dec(Len,trailing);
if BEnd-B>integer(n+1) shl 2 then begin
// will fit in available space in Buf -> fast in-buffer Base64 encoding
n := Base64EncodeMain(@B[1],P,Len);
inc(B,n*4);
inc(P,n*3);
end else begin
// bigger than available space in Buf -> do it per chunk
FlushToStream;
while Len>0 do begin // length(buf) const -> so is ((length(buf)-4)shr2 )*3
n := ((fTempBufSize-4)shr 2)*3;
if Len<n then
n := Len;
main := Base64EncodeMain(PAnsiChar(fTempBuf),P,n);
n := main*4;
if n<cardinal(fTempBufSize)-4 then
inc(B,n) else
WriteToStream(fTempBuf,n);
n := main*3;
inc(P,n);
dec(Len,n);
end;
end;
if trailing>0 then begin
Base64EncodeTrailing(@B[1],P,trailing);
inc(B,4);
end;
end;
if withMagic then
Add('"');
end;
{ TTextWriterWithEcho }
procedure TTextWriterWithEcho.AddEndOfLine(aLevel: TSynLogInfo=sllNone);
var i: integer;
begin
if BEnd-B<=1 then
FlushToStream;
if twoEndOfLineCRLF in fCustomOptions then begin
PWord(B+1)^ := 13+10 shl 8; // CR + LF
inc(B,2);
end else begin
B[1] := #10; // LF
inc(B);
end;
if fEchos<>nil then begin
fEchoStart := EchoFlush;
for i := length(fEchos)-1 downto 0 do // for MultiEventRemove() below
try
fEchos[i](self,aLevel,fEchoBuf);
except // remove callback in case of exception during echoing in user code
MultiEventRemove(fEchos,i);
end;
fEchoBuf := '';
end;
end;
procedure TTextWriterWithEcho.FlushToStream;
begin
if fEchos<>nil then begin
EchoFlush;
fEchoStart := 0;
end;
inherited FlushToStream;
end;
procedure TTextWriterWithEcho.EchoAdd(const aEcho: TOnTextWriterEcho);
begin
if self<>nil then
if MultiEventAdd(fEchos,TMethod(aEcho)) then
if fEchos<>nil then
fEchoStart := B-fTempBuf+1; // ignore any previous buffer
end;
procedure TTextWriterWithEcho.EchoRemove(const aEcho: TOnTextWriterEcho);
begin
if self<>nil then
MultiEventRemove(fEchos,TMethod(aEcho));
end;
function TTextWriterWithEcho.EchoFlush: PtrInt;
var L,LI: PtrInt;
P: PByteArray;
begin
result := B-fTempBuf+1;
L := result-fEchoStart;
P := @PByteArray(fTempBuf)[fEchoStart];
while (L>0) and (P[L-1] in [10,13]) do // trim right CR/LF chars
dec(L);
LI := length(fEchoBuf); // fast append to fEchoBuf
SetLength(fEchoBuf,LI+L);
MoveFast(P^,PByteArray(fEchoBuf)[LI],L);
end;
procedure TTextWriterWithEcho.EchoReset;
begin
fEchoBuf := '';
end;
function TTextWriterWithEcho.GetEndOfLineCRLF: boolean;
begin
result := twoEndOfLineCRLF in fCustomOptions;
end;
procedure TTextWriterWithEcho.SetEndOfLineCRLF(aEndOfLineCRLF: boolean);
begin
if aEndOfLineCRLF then
include(fCustomOptions,twoEndOfLineCRLF) else
exclude(fCustomOptions,twoEndOfLineCRLF);
end;
function JSONEncode(const NameValuePairs: array of const): RawUTF8;
var temp: TTextWriterStackBuffer;
begin
if high(NameValuePairs)<1 then
result := '{}' else // return void JSON object on error
with DefaultTextWriterSerializer.CreateOwnedStream(temp) do
try
AddJSONEscape(NameValuePairs);
SetText(result);
finally
Free
end;
end;
{$ifndef NOVARIANTS}
function JSONEncode(const Format: RawUTF8; const Args,Params: array of const): RawUTF8;
var temp: TTextWriterStackBuffer;
begin
with DefaultTextWriterSerializer.CreateOwnedStream(temp) do
try
AddJSON(Format,Args,Params);
SetText(result);
finally
Free
end;
end;
{$endif}
function JSONEncodeArrayDouble(const Values: array of double): RawUTF8;
var W: TTextWriter;
temp: TTextWriterStackBuffer;
begin
W := TTextWriter.CreateOwnedStream(temp);
try
W.Add('[');
W.AddCSVDouble(Values);
W.Add(']');
W.SetText(result);
finally
W.Free
end;
end;
function JSONEncodeArrayUTF8(const Values: array of RawUTF8): RawUTF8;
var W: TTextWriter;
temp: TTextWriterStackBuffer;
begin
W := TTextWriter.CreateOwnedStream(temp);
try
W.Add('[');
W.AddCSVUTF8(Values);
W.Add(']');
W.SetText(result);
finally
W.Free
end;
end;
function JSONEncodeArrayInteger(const Values: array of integer): RawUTF8;
var W: TTextWriter;
temp: TTextWriterStackBuffer;
begin
W := TTextWriter.CreateOwnedStream(temp);
try
W.Add('[');
W.AddCSVInteger(Values);
W.Add(']');
W.SetText(result);
finally
W.Free
end;
end;
function JSONEncodeArrayOfConst(const Values: array of const;
WithoutBraces: boolean): RawUTF8;
begin
JSONEncodeArrayOfConst(Values,WithoutBraces,result);
end;
procedure JSONEncodeArrayOfConst(const Values: array of const;
WithoutBraces: boolean; var result: RawUTF8);
var temp: TTextWriterStackBuffer;
begin
if length(Values)=0 then
if WithoutBraces then
result := '' else
result := '[]' else
with DefaultTextWriterSerializer.CreateOwnedStream(temp) do
try
if not WithoutBraces then
Add('[');
AddCSVConst(Values);
if not WithoutBraces then
Add(']');
SetText(result);
finally
Free
end;
end;
procedure JSONEncodeNameSQLValue(const Name,SQLValue: RawUTF8;
var result: RawUTF8);
var temp: TTextWriterStackBuffer;
begin
if (SQLValue<>'') and (SQLValue[1] in ['''','"']) then
// unescape SQL quoted string value into a valid JSON string
with TTextWriter.CreateOwnedStream(temp) do
try
Add('{','"');
AddNoJSONEscapeUTF8(Name);
Add('"',':');
AddQuotedStringAsJSON(SQLValue);
Add('}');
SetText(result);
finally
Free;
end else
// Value is a number or null/true/false
result := '{"'+Name+'":'+SQLValue+'}';
end;
{ TValuePUTF8Char }
procedure TValuePUTF8Char.ToUTF8(var Text: RawUTF8);
begin
FastSetString(Text,Value,ValueLen);
end;
function TValuePUTF8Char.ToUTF8: RawUTF8;
begin
FastSetString(result,Value,ValueLen);
end;
function TValuePUTF8Char.ToString: string;
begin
UTF8DecodeToString(Value,ValueLen,result);
end;
function TValuePUTF8Char.ToInteger: PtrInt;
begin
result := GetInteger(Value);
end;
function TValuePUTF8Char.ToCardinal: PtrUInt;
begin
result := GetCardinal(Value);
end;
function TValuePUTF8Char.Idem(const Text: RawUTF8): boolean;
begin
if length(Text)=ValueLen then
result := IdemPropNameUSameLen(pointer(Text),Value,ValueLen) else
result := false;
end;
procedure JSONDecode(var JSON: RawUTF8; const Names: array of RawUTF8;
Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean);
begin
JSONDecode(UniqueRawUTF8(JSON),Names,Values,HandleValuesAsObjectOrArray);
end;
procedure JSONDecode(var JSON: RawJSON; const Names: array of RawUTF8;
Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean);
begin
JSONDecode(UniqueRawUTF8(RawUTF8(JSON)),Names,Values,HandleValuesAsObjectOrArray);
end;
function JSONDecode(P: PUTF8Char; const Names: array of RawUTF8;
Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean): PUTF8Char;
var n, i: PtrInt;
namelen, valuelen: integer;
name, value: PUTF8Char;
EndOfObject: AnsiChar;
begin
result := nil;
if Values=nil then
exit; // avoid GPF
n := length(Names);
FillCharFast(Values[0],n*SizeOf(Values[0]),0);
dec(n);
if P=nil then
exit;
while P^<>'{' do
if P^=#0 then
exit else
inc(P);
inc(P); // jump {
repeat
name := GetJSONPropName(P,@namelen);
if name=nil then
exit; // invalid JSON content
value := GetJSONFieldOrObjectOrArray(P,nil,@EndOfObject,HandleValuesAsObjectOrArray,true,@valuelen);
if not(EndOfObject in [',','}']) then
exit; // invalid item separator
for i := 0 to n do
if (Values[i].Value=nil) and IdemPropNameU(Names[i],name,namelen) then begin
Values[i].Value := value;
Values[i].ValueLen := valuelen;
break;
end;
until (P=nil) or (EndOfObject='}');
if P=nil then // result=nil indicates failure -> points to #0 for end of text
result := @NULCHAR else
result := P;
end;
function JSONDecode(var JSON: RawUTF8; const aName: RawUTF8;
wasString: PBoolean; HandleValuesAsObjectOrArray: Boolean): RawUTF8;
var P, Name, Value: PUTF8Char;
NameLen, ValueLen: integer;
EndOfObject: AnsiChar;
begin
result := '';
P := pointer(JSON);
if P=nil then
exit;
while P^<>'{' do
if P^=#0 then
exit else
inc(P);
inc(P); // jump {
repeat
Name := GetJSONPropName(P,@NameLen);
if Name=nil then
exit; // invalid JSON content
Value := GetJSONFieldOrObjectOrArray(
P,wasString,@EndOfObject,HandleValuesAsObjectOrArray,true,@ValueLen);
if not(EndOfObject in [',','}']) then
exit; // invalid item separator
if IdemPropNameU(aName,Name,NameLen) then begin
FastSetString(result,Value,ValueLen);
exit;
end;
until (P=nil) or (EndOfObject='}');
end;
function JSONDecode(P: PUTF8Char; out Values: TNameValuePUTF8CharDynArray;
HandleValuesAsObjectOrArray: Boolean): PUTF8Char;
var n: PtrInt;
field: TNameValuePUTF8Char;
EndOfObject: AnsiChar;
begin
{$ifdef FPC}
Values := nil;
{$endif}
result := nil;
n := 0;
if P<>nil then begin
while P^<>'{' do
if P^=#0 then
exit else
inc(P);
inc(P); // jump {
repeat
field.Name := GetJSONPropName(P,@field.NameLen);
if field.Name=nil then
exit; // invalid JSON content
field.Value := GetJSONFieldOrObjectOrArray(P,nil,@EndOfObject,
HandleValuesAsObjectOrArray,true,@field.ValueLen);
if not(EndOfObject in [',','}']) then
exit; // invalid item separator
if n=length(Values) then
SetLength(Values,n+32);
Values[n] := field;
inc(n);
until (P=nil) or (EndOfObject='}');
end;
SetLength(Values,n);
if P=nil then // result=nil indicates failure -> points to #0 for end of text
result := @NULCHAR else
result := P;
end;
function JSONRetrieveStringField(P: PUTF8Char; out Field: PUTF8Char;
out FieldLen: integer; ExpectNameField: boolean): PUTF8Char;
begin
result := nil;
// retrieve string field
if P=nil then
exit;
while (P^<=' ') and (P^<>#0) do inc(P);
if P^<>'"' then exit;
Field := P+1;
P := GotoEndOfJSONString(P);
if P^<>'"' then
exit; // here P^ should be '"'
FieldLen := P-Field;
// check valid JSON delimiter
repeat inc(P) until (P^>' ') or (P^=#0);
if ExpectNameField then begin
if P^<>':' then
exit; // invalid name field
end else
if not (P^ in ['}',',']) then
exit; // invalid value field
result := P; // return either ':' for name field, either '}',',' for value
end;
// decode a JSON field into an UTF-8 encoded buffer, stored inplace of input buffer
function GetJSONField(P: PUTF8Char; out PDest: PUTF8Char;
wasString: PBoolean; EndOfObject: PUTF8Char; Len: PInteger): PUTF8Char;
var D: PUTF8Char;
c4,surrogate,j: integer;
c: AnsiChar;
b: byte;
jsonset: PJsonCharSet;
{$ifdef CPUX86NOTPIC} tab: TNormTableByte absolute ConvertHexToBin;
{$else} tab: PNormTableByte; {$endif}
label slash,num,lit;
begin // see http://www.ietf.org/rfc/rfc4627.txt
if wasString<>nil then
wasString^ := false; // not a string by default
if Len<>nil then
Len^ := 0; // avoid buffer overflow on parsing error
PDest := nil; // PDest=nil indicates parsing error (e.g. unexpected #0 end)
result := nil;
if P=nil then exit;
if P^<=' ' then repeat inc(P); if P^=#0 then exit; until P^>' ';
case P^ of
'"': begin // " -> unescape P^ into D^
if wasString<>nil then
wasString^ := true;
inc(P);
result := P;
D := P;
repeat
c := P^;
if c=#0 then exit else
if c='"' then break else
if c='\' then goto slash;
inc(P);
D^ := c;
inc(D);
continue;
slash:inc(P); // unescape JSON string
c := P^;
if (c='"') or (c='\') then begin
lit: inc(P);
D^ := c; // most common case
inc(D);
continue;
end else
if c=#0 then
exit else // to avoid potential buffer overflow issue on \#0
if c='b' then
c := #8 else
if c='t' then
c := #9 else
if c='n' then
c := #10 else
if c='f' then
c := #12 else
if c='r' then
c := #13 else
if c='u' then begin
// inlined decoding of '\u0123' UTF-16 codepoint(s) into UTF-8
{$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif}
c4 := tab[ord(P[1])];
if c4<=15 then begin
b := tab[ord(P[2])];
if b<=15 then begin
c4 := c4 shl 4;
c4 := c4 or b;
b := tab[ord(P[3])];
if b<=15 then begin
c4 := c4 shl 4;
c4 := c4 or b;
b := tab[ord(P[4])];
if b<=15 then begin
c4 := c4 shl 4;
c4 := c4 or b;
case c4 of
0: begin
D^ := '?'; // \u0000 is an invalid value
inc(D);
end;
1..$7f: begin
D^ := AnsiChar(c4);
inc(D);
end;
$80..$7ff: begin
D[0] := AnsiChar($C0 or (c4 shr 6));
D[1] := AnsiChar($80 or (c4 and $3F));
inc(D,2);
end;
UTF16_HISURROGATE_MIN..UTF16_LOSURROGATE_MAX:
if PWord(P+5)^=ord('\')+ord('u') shl 8 then begin
inc(P,6); // optimistic conversion (no check)
surrogate := (ConvertHexToBin[ord(P[1])] shl 12)+
(ConvertHexToBin[ord(P[2])] shl 8)+
(ConvertHexToBin[ord(P[3])] shl 4)+
ConvertHexToBin[ord(P[4])];
case c4 of // inlined UTF16CharToUtf8()
UTF16_HISURROGATE_MIN..UTF16_HISURROGATE_MAX:
c4 := ((c4-$D7C0)shl 10)+(surrogate xor UTF16_LOSURROGATE_MIN);
UTF16_LOSURROGATE_MIN..UTF16_LOSURROGATE_MAX:
c4 := ((surrogate-$D7C0)shl 10)+(c4 xor UTF16_LOSURROGATE_MIN);
end;
case c4 of
0..$7ff: b := 2;
$800..$ffff: b := 3;
$10000..$1FFFFF: b := 4;
$200000..$3FFFFFF: b := 5;
else b := 6;
end;
for j := b-1 downto 1 do begin
D[j] := AnsiChar((c4 and $3f)+$80);
c4 := c4 shr 6;
end;
D^ := AnsiChar(Byte(c4) or UTF8_FIRSTBYTE[b]);
inc(D,b);
end else begin
D^ := '?'; // unexpected surrogate without its pair
inc(D);
end;
else begin
D[0] := AnsiChar($E0 or (c4 shr 12));
D[1] := AnsiChar($80 or ((c4 shr 6) and $3F));
D[2] := AnsiChar($80 or (c4 and $3F));
inc(D,3);
end;
end;
inc(P,5);
continue;
end;
end;
end;
end;
c := '?'; // bad formated hexa number -> '?0123'
end;
goto lit;
until false;
// here P^='"'
D^ := #0; // make zero-terminated
if Len<>nil then
Len^ := D-result;
inc(P);
if P^=#0 then
exit;
end;
'0':
if P[1] in ['0'..'9'] then // 0123 excluded by JSON!
exit else // leave PDest=nil for unexpected end
goto num;// may be 0.123
'-','1'..'9': begin // numerical field: all chars before end of field
num:result := P;
jsonset := @JSON_CHARS;
repeat
if not (jcDigitFloatChar in jsonset[P^]) then
break;
inc(P);
until false;
if P^=#0 then
exit;
if Len<>nil then
Len^ := P-result;
if P^<=' ' then begin
P^ := #0; // force numerical field with no trailing ' '
inc(P);
end;
end;
'n':
if (PInteger(P)^=NULL_LOW) and (jcEndOfJSONValueField in JSON_CHARS[P[4]]) then begin
result := nil; // null -> returns nil and wasString=false
if Len<>nil then
Len^ := 0; // when result is converted to string
inc(P,4);
end else
exit;
'f':
if (PInteger(P+1)^=FALSE_LOW2) and (jcEndOfJSONValueField in JSON_CHARS[P[5]]) then begin
result := P; // false -> returns 'false' and wasString=false
if Len<>nil then
Len^ := 5;
inc(P,5);
end else
exit;
't':
if (PInteger(P)^=TRUE_LOW) and (jcEndOfJSONValueField in JSON_CHARS[P[4]]) then begin
result := P; // true -> returns 'true' and wasString=false
if Len<>nil then
Len^ := 4;
inc(P,4);
end else
exit;
else
exit; // PDest=nil to indicate error
end;
jsonset := @JSON_CHARS;
while not (jcEndOfJSONField in jsonset[P^]) do begin
if P^=#0 then
exit; // leave PDest=nil for unexpected end
inc(P);
end;
if EndOfObject<>nil then
EndOfObject^ := P^;
P^ := #0; // make zero-terminated
PDest := @P[1];
if P[1]=#0 then
PDest := nil;
end;
function GetJSONPropName(var P: PUTF8Char; Len: PInteger): PUTF8Char;
var Name: PUTF8Char;
wasString: boolean;
c, EndOfObject: AnsiChar;
tab: PJsonCharSet;
begin // should match GotoNextJSONObjectOrArray() and JsonPropNameValid()
result := nil;
if P=nil then
exit;
while (P^<=' ') and (P^<>#0) do inc(P);
Name := P; // put here to please some versions of Delphi compiler
c := P^;
if c='"' then begin
Name := GetJSONField(P,P,@wasString,@EndOfObject,Len);
if (Name=nil) or not wasString or (EndOfObject<>':') then
exit;
end else
if c = '''' then begin // single quotes won't handle nested quote character
inc(P);
Name := P;
while P^<>'''' do
if P^<' ' then
exit else
inc(P);
if Len<>nil then
Len^ := P-Name;
P^ := #0;
repeat inc(P) until (P^>' ') or (P^=#0);
if P^<>':' then
exit;
inc(P);
end else begin // e.g. '{age:{$gt:18}}'
tab := @JSON_CHARS;
if not (jcJsonIdentifierFirstChar in tab[c]) then
exit;
repeat
inc(P);
until not (jcJsonIdentifier in tab[P^]);
if Len<>nil then
Len^ := P-Name;
if (P^<=' ') and (P^<>#0) then begin
P^ := #0;
inc(P);
end;
while (P^<=' ') and (P^<>#0) do inc(P);
if not (P^ in [':','=']) then // allow both age:18 and age=18 pairs
exit;
P^ := #0;
inc(P);
end;
result := Name;
end;
procedure GetJSONPropName(var P: PUTF8Char; out PropName: shortstring);
var Name: PAnsiChar;
c: AnsiChar;
tab: PJsonCharSet;
begin // match GotoNextJSONObjectOrArray() and overloaded GetJSONPropName()
PropName[0] := #0;
if P=nil then
exit;
while (P^<=' ') and (P^<>#0) do inc(P);
Name := pointer(P);
c := P^;
if c='"' then begin
inc(Name);
P := GotoEndOfJSONString(P);
if P^<>'"' then
exit;
SetString(PropName,Name,P-Name); // note: won't unescape JSON strings
repeat inc(P) until (P^>' ') or (P^=#0);
if P^<>':' then begin
PropName[0] := #0;
exit;
end;
inc(P);
end else
if c='''' then begin // single quotes won't handle nested quote character
inc(P);
inc(Name);
while P^<>'''' do
if P^<' ' then
exit else
inc(P);
SetString(PropName,Name,P-Name);
repeat inc(P) until (P^>' ') or (P^=#0);
if P^<>':' then begin
PropName[0] := #0;
exit;
end;
inc(P);
end else begin // e.g. '{age:{$gt:18}}'
tab := @JSON_CHARS;
if not (jcJsonIdentifierFirstChar in tab[c]) then
exit;
repeat
inc(P);
until not (jcJsonIdentifier in tab[P^]);
SetString(PropName,Name,P-Name);
while (P^<=' ') and (P^<>#0) do inc(P);
if not (P^ in [':','=']) then begin // allow both age:18 and age=18 pairs
PropName[0] := #0;
exit;
end;
inc(P);
end;
end;
function GotoNextJSONPropName(P: PUTF8Char): PUTF8Char;
var c: AnsiChar;
tab: PJsonCharSet;
label s;
begin // should match GotoNextJSONObjectOrArray()
while (P^<=' ') and (P^<>#0) do inc(P);
result := nil;
if P=nil then
exit;
c := P^;
if c='"' then begin
P := GotoEndOfJSONString(P);
if P^<>'"' then
exit;
s: repeat inc(P) until (P^>' ') or (P^=#0);
if P^<>':' then
exit;
end else
if c='''' then begin // single quotes won't handle nested quote character
inc(P);
while P^<>'''' do
if P^<' ' then
exit else
inc(P);
goto s;
end else begin // e.g. '{age:{$gt:18}}'
tab := @JSON_CHARS;
if not (jcJsonIdentifierFirstChar in tab[c]) then
exit;
repeat
inc(P);
until not (jcJsonIdentifier in tab[P^]);
if (P^<=' ') and (P^<>#0) then
inc(P);
while (P^<=' ') and (P^<>#0) do inc(P);
if not (P^ in [':','=']) then // allow both age:18 and age=18 pairs
exit;
end;
repeat inc(P) until (P^>' ') or (P^=#0);
result := P;
end;
function GetJSONFieldOrObjectOrArray(var P: PUTF8Char; wasString: PBoolean;
EndOfObject: PUTF8Char; HandleValuesAsObjectOrArray: Boolean;
NormalizeBoolean: Boolean; Len: PInteger): PUTF8Char;
var Value: PUTF8Char;
wStr: boolean;
begin
result := nil;
if P=nil then
exit;
while ord(P^) in [1..32] do inc(P);
if HandleValuesAsObjectOrArray and (P^ in ['{','[']) then begin
Value := P;
P := GotoNextJSONObjectOrArray(P);
if P=nil then
exit; // invalid content
if Len<>nil then
Len^ := P-Value;
if wasString<>nil then
wasString^ := false; // was object or array
while ord(P^) in [1..32] do inc(P);
if EndOfObject<>nil then
EndOfObject^ := P^;
P^ := #0; // make zero-terminated
if P[1]=#0 then
P := nil else
inc(P);
result := Value;
end else begin
result := GetJSONField(P,P,@wStr,EndOfObject,Len);
if wasString<>nil then
wasString^ := wStr;
if not wStr and NormalizeBoolean and (result<>nil) then begin
if PInteger(result)^=TRUE_LOW then
result := pointer(SmallUInt32UTF8[1]) else // normalize true -> 1
if PInteger(result)^=FALSE_LOW then
result := pointer(SmallUInt32UTF8[0]) else // normalize false -> 0
exit;
if Len<>nil then
Len^ := 1;
end;
end;
end;
function IsString(P: PUTF8Char): boolean; // test if P^ is a "string" value
begin
if P=nil then begin
result := false;
exit;
end;
while (P^<=' ') and (P^<>#0) do inc(P);
if (P[0] in ['0'..'9']) or // is first char numeric?
((P[0] in ['-','+']) and (P[1] in ['0'..'9'])) then begin
// check if P^ is a true numerical value
repeat inc(P) until not (P^ in ['0'..'9']); // check digits
if P^='.' then
repeat inc(P) until not (P^ in ['0'..'9']); // check fractional digits
if ((P^='e') or (P^='E')) and (P[1] in ['0'..'9','+','-']) then begin
inc(P);
if P^='+' then inc(P) else
if P^='-' then inc(P);
while (P^>='0') and (P^<='9') do inc(P);
end;
while (P^<=' ') and (P^<>#0) do inc(P);
result := (P^<>#0);
exit;
end else
result := true; // don't begin with a numerical value -> must be a string
end;
function IsStringJSON(P: PUTF8Char): boolean; // test if P^ is a "string" value
var c4: integer;
c: AnsiChar;
tab: PJsonCharSet;
begin
if P=nil then begin
result := false;
exit;
end;
while (P^<=' ') and (P^<>#0) do inc(P);
tab := @JSON_CHARS;
c4 := PInteger(P)^;
if (((c4=NULL_LOW)or(c4=TRUE_LOW)) and (jcEndOfJSONValueField in tab[P[4]])) or
((c4=FALSE_LOW) and (P[4]='e') and (jcEndOfJSONValueField in tab[P[5]])) then begin
result := false; // constants are no string
exit;
end;
c := P^;
if (jcDigitFirstChar in tab[c]) and
(((c>='1') and (c<='9')) or // is first char numeric?
((c='0') and ((P[1]<'0') or (P[1]>'9'))) or // '012' excluded by JSON
((c='-') and (P[1]>='0') and (P[1]<='9'))) then begin
// check if c is a true numerical value
repeat inc(P) until (P^<'0') or (P^>'9'); // check digits
if P^='.' then
repeat inc(P) until (P^<'0') or (P^>'9'); // check fractional digits
if ((P^='e') or (P^='E')) and (jcDigitChar in tab[P[1]]) then begin
inc(P);
c := P^;
if c='+' then inc(P) else
if c='-' then inc(P);
while (P^>='0') and (P^<='9') do inc(P);
end;
while (P^<=' ') and (P^<>#0) do inc(P);
result := (P^<>#0);
exit;
end else
result := true; // don't begin with a numerical value -> must be a string
end;
function IsValidJSON(const s: RawUTF8): boolean;
begin
result := IsValidJSON(pointer(s),length(s));
end;
function IsValidJSON(P: PUTF8Char; len: PtrInt): boolean;
var B: PUTF8Char;
begin
result := false;
if (P=nil) or (len<=0) or (StrLen(P)<>len) then
exit;
B := P;
P := GotoEndJSONItem(B,{strict=}true);
result := (P<>nil) and (P-B=len);
end;
procedure GetJSONItemAsRawJSON(var P: PUTF8Char; var result: RawJSON;
EndOfObject: PAnsiChar);
var B: PUTF8Char;
begin
result := '';
if P=nil then
exit;
B := GotoNextNotSpace(P);
P := GotoEndJSONItem(B);
if P=nil then
exit;
FastSetString(RawUTF8(result),B,P-B);
while (P^<=' ') and (P^<>#0) do inc(P);
if EndOfObject<>nil then
EndOfObject^ := P^;
if P^<>#0 then //if P^=',' then
repeat inc(P) until (P^>' ') or (P^=#0);
end;
function GetJSONItemAsRawUTF8(var P: PUTF8Char; var output: RawUTF8;
wasString: PBoolean; EndOfObject: PUTF8Char): boolean;
var V: PUTF8Char;
VLen: integer;
begin
V := GetJSONFieldOrObjectOrArray(P,wasstring,EndOfObject,true,true,@VLen);
if V=nil then // parsing error
result := false else begin
FastSetString(output,V,VLen);
result := true;
end;
end;
function GotoNextJSONObjectOrArrayInternal(P,PMax: PUTF8Char; EndChar: AnsiChar): PUTF8Char;
var tab: PJsonCharSet;
label Prop;
begin // should match GetJSONPropName()
result := nil;
repeat
case P^ of
'{','[': begin
if PMax=nil then
P := GotoNextJSONObjectOrArray(P) else
P := GotoNextJSONObjectOrArrayMax(P,PMax);
if P=nil then exit;
end;
':': if EndChar<>'}' then exit else inc(P); // syntax for JSON object only
',': inc(P); // comma appears in both JSON objects and arrays
'}': if EndChar='}' then break else exit;
']': if EndChar=']' then break else exit;
'"': begin
P := GotoEndOfJSONString(P);
if P^<>'"' then
exit;
inc(P);
end;
'-','+','0'..'9': begin // '0123' excluded by JSON, but not here
tab := @JSON_CHARS;
repeat
inc(P);
until not (jcDigitFloatChar in tab[P^]);
end;
't': if PInteger(P)^=TRUE_LOW then inc(P,4) else goto Prop;
'f': if PInteger(P+1)^=FALSE_LOW2 then inc(P,5) else goto Prop;
'n': if PInteger(P)^=NULL_LOW then inc(P,4) else goto Prop;
'''': begin // single-quoted identifier
repeat inc(P); if P^<=' ' then exit; until P^='''';
repeat inc(P) until (P^>' ') or (P^=#0);
if P^<>':' then exit;
end;
'/': begin
repeat // allow extended /regex/ syntax
inc(P);
if P^=#0 then
exit;
until P^='/';
repeat inc(P) until (P^>' ') or (P^=#0);
end;
else begin
Prop: tab := @JSON_CHARS;
if not (jcJsonIdentifierFirstChar in tab[P^]) then
exit;
repeat
inc(P);
until not (jcJsonIdentifier in tab[P^]);
while (P^<=' ') and (P^<>#0) do inc(P);
if P^='(' then begin // handle e.g. "born":isodate("1969-12-31")
inc(P);
while (P^<=' ') and (P^<>#0) do inc(P);
if P^='"' then begin
P := GotoEndOfJSONString(P);
if P^<>'"' then
exit;
end;
inc(P);
while (P^<=' ') and (P^<>#0) do inc(P);
if P^<>')' then
exit;
inc(P);
end
else
if P^<>':' then exit;
end;
end;
while (P^<=' ') and (P^<>#0) do inc(P);
if (PMax<>nil) and (P>=PMax) then
exit;
until P^=EndChar;
result := P+1;
end;
function GotoEndJSONItem(P: PUTF8Char; strict: boolean): PUTF8Char;
var tab: PJsonCharSet;
label pok,ok;
begin
result := nil; // to notify unexpected end
if P=nil then
exit;
while (P^<=' ') and (P^<>#0) do inc(P);
case P^ of
#0: exit;
'"': begin
P := GotoEndOfJSONString(P);
if P^<>'"' then
exit;
inc(P);
goto ok;
end;
'[': begin
repeat inc(P) until (P^>' ') or (P^=#0);
P := GotoNextJSONObjectOrArrayInternal(P,nil,']');
goto pok;
end;
'{': begin
repeat inc(P) until (P^>' ') or (P^=#0);
P := GotoNextJSONObjectOrArrayInternal(P,nil,'}');
pok:if P=nil then
exit;
ok: while (P^<=' ') and (P^<>#0) do inc(P);
result := P;
exit;
end;
end;
if strict then
case P^ of
't': if PInteger(P)^=TRUE_LOW then begin inc(P,4); goto ok; end;
'f': if PInteger(P+1)^=FALSE_LOW2 then begin inc(P,5); goto ok; end;
'n': if PInteger(P)^=NULL_LOW then begin inc(P,4); goto ok; end;
'-','+','0'..'9': begin
tab := @JSON_CHARS;
repeat inc(P) until not (jcDigitFloatChar in tab[P^]);
goto ok;
end;
end else begin // not strict
tab := @JSON_CHARS;
repeat // numeric or true/false/null or MongoDB extended {age:{$gt:18}}
inc(P);
until jcEndOfJSONFieldOr0 in tab[P^];
if P^=#0 then exit; // unexpected end
end;
if P^=#0 then
exit;
result := P;
end;
function GotoNextJSONItem(P: PUTF8Char; NumberOfItemsToJump: cardinal;
EndOfObject: PAnsiChar): PUTF8Char;
var tab: PJsonCharSet;
label pok,n;
begin
result := nil; // to notify unexpected end
while NumberOfItemsToJump>0 do begin
while (P^<=' ') and (P^<>#0) do inc(P);
// get a field
case P^ of
#0: exit;
'"': begin
P := GotoEndOfJSONString(P);
if P^<>'"' then
exit; // P^ should be '"' here
end;
'[': begin
repeat inc(P) until (P^>' ') or (P^=#0);
P := GotoNextJSONObjectOrArrayInternal(P,nil,']');
goto pok;
end;
'{': begin
repeat inc(P) until (P^>' ') or (P^=#0);
P := GotoNextJSONObjectOrArrayInternal(P,nil,'}');
pok: if P=nil then
exit;
while (P^<=' ') and (P^<>#0) do inc(P);
goto n;
end;
end;
tab := @JSON_CHARS;
repeat // numeric or true/false/null or MongoDB extended {age:{$gt:18}}
inc(P);
until jcEndOfJSONFieldOr0 in tab[P^];
n: if P^=#0 then
exit;
if EndOfObject<>nil then
EndOfObject^ := P^;
inc(P);
dec(NumberOfItemsToJump);
end;
result := P;
end;
function GotoNextJSONObjectOrArray(P: PUTF8Char): PUTF8Char;
var EndChar: AnsiChar;
begin // should match GetJSONPropName()
result := nil; // mark error or unexpected end (#0)
while (P^<=' ') and (P^<>#0) do inc(P);
case P^ of
'[': EndChar := ']';
'{': EndChar := '}';
else exit;
end;
repeat inc(P) until (P^>' ') or (P^=#0);
result := GotoNextJSONObjectOrArrayInternal(P,nil,EndChar);
end;
function GotoNextJSONObjectOrArray(P: PUTF8Char; EndChar: AnsiChar): PUTF8Char;
begin // should match GetJSONPropName()
while (P^<=' ') and (P^<>#0) do inc(P);
result := GotoNextJSONObjectOrArrayInternal(P,nil,EndChar);
end;
function GotoNextJSONObjectOrArrayMax(P,PMax: PUTF8Char): PUTF8Char;
var EndChar: AnsiChar;
begin // should match GetJSONPropName()
result := nil; // mark error or unexpected end (#0)
while (P^<=' ') and (P^<>#0) do inc(P);
case P^ of
'[': EndChar := ']';
'{': EndChar := '}';
else exit;
end;
repeat inc(P) until (P^>' ') or (P^=#0);
result := GotoNextJSONObjectOrArrayInternal(P,PMax,EndChar);
end;
function JSONArrayCount(P: PUTF8Char): integer;
var n: integer;
begin
result := -1;
n := 0;
P := GotoNextNotSpace(P);
if P^<>']' then
repeat
case P^ of
'"': begin
P := GotoEndOfJSONString(P);
if P^<>'"' then
exit;
inc(P);
end;
'{','[': begin
P := GotoNextJSONObjectOrArray(P);
if P=nil then
exit; // invalid content
end;
end;
while not (P^ in [#0,',',']']) do inc(P);
inc(n);
if P^<>',' then break;
repeat inc(P) until (P^>' ') or (P^=#0);
until false;
if P^=']' then
result := n;
end;
function JSONArrayDecode(P: PUTF8Char; out Values: TPUTF8CharDynArray): boolean;
var n,max: integer;
begin
result := false;
max := 0;
n := 0;
P := GotoNextNotSpace(P);
if P^<>']' then
repeat
if max=n then begin
max := NextGrow(max);
SetLength(Values,max);
end;
Values[n] := P;
case P^ of
'"': begin
P := GotoEndOfJSONString(P);
if P^<>'"' then
exit;
inc(P);
end;
'{','[': begin
P := GotoNextJSONObjectOrArray(P);
if P=nil then
exit; // invalid content
end;
end;
while not (P^ in [#0,',',']']) do inc(P);
inc(n);
if P^<>',' then break;
repeat inc(P) until (P^>' ') or (P^=#0);
until false;
if P^=']' then begin
SetLength(Values,n);
result := true;
end else
Values := nil;
end;
function JSONArrayItem(P: PUTF8Char; Index: integer): PUTF8Char;
begin
if P<>nil then begin
P := GotoNextNotSpace(P);
if P^='[' then begin
P := GotoNextNotSpace(P+1);
if P^<>']' then
repeat
if Index<=0 then begin
result := P;
exit;
end;
case P^ of
'"': begin
P := GotoEndOfJSONString(P);
if P^<>'"' then
break; // invalid content
inc(P);
end;
'{','[': begin
P := GotoNextJSONObjectOrArray(P);
if P=nil then
break; // invalid content
end;
end;
while not (P^ in [#0,',',']']) do inc(P);
if P^<>',' then break;
repeat inc(P) until (P^>' ') or (P^=#0);
dec(Index);
until false;
end;
end;
result := nil;
end;
function JSONArrayCount(P,PMax: PUTF8Char): integer;
var n: integer;
begin
result := -1;
n := 0;
P := GotoNextNotSpace(P);
if P^<>']' then
while P<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 (P^>' ') or (P^=#0);
end;
if P^=']' then
result := n;
end;
function JSONObjectPropCount(P: PUTF8Char): integer;
var n: integer;
begin
result := -1;
n := 0;
P := GotoNextNotSpace(P);
if P^<>'}' then
repeat
P := GotoNextJSONPropName(P);
if P=nil then
exit;
case P^ of
'"': begin
P := GotoEndOfJSONString(P);
if P^<>'"' then
exit;
inc(P);
end;
'{','[': begin
P := GotoNextJSONObjectOrArray(P);
if P=nil then
exit; // invalid content
end;
end;
while not (P^ in [#0,',','}']) do inc(P);
inc(n);
if P^<>',' then break;
repeat inc(P) until (P^>' ') or (P^=#0);
until false;
if P^='}' then
result := n;
end;
function JsonObjectItem(P: PUTF8Char; const PropName: RawUTF8;
PropNameFound: PRawUTF8): PUTF8Char;
var name: shortstring; // no memory allocation nor P^ modification
PropNameLen: integer;
PropNameUpper: array[byte] of AnsiChar;
begin
if P<>nil then begin
P := GotoNextNotSpace(P);
PropNameLen := length(PropName);
if PropNameLen<>0 then begin
if PropName[PropNameLen]='*' then begin
UpperCopy255Buf(PropNameUpper,pointer(PropName),PropNameLen-1)^ := #0;
PropNameLen := 0;
end;
if P^='{' then
P := GotoNextNotSpace(P+1);
if P^<>'}' then
repeat
GetJSONPropName(P,name);
if (name[0]=#0) or (name[0]>#200) then
break;
while (P^<=' ') and (P^<>#0) do inc(P);
if PropNameLen=0 then begin
name[ord(name[0])+1] := #0; // make ASCIIZ
if IdemPChar(@name[1],PropNameUpper) then begin
if PropNameFound<>nil then
FastSetString(PropNameFound^,@name[1],ord(name[0]));
result := P;
exit;
end;
end else
if IdemPropName(name,pointer(PropName),PropNameLen) then begin
result := P;
exit;
end;
case P^ of
'"': begin
P := GotoEndOfJSONString(P);
if P^<>'"' then
break; // invalid content
inc(P);
end;
'{','[': begin
P := GotoNextJSONObjectOrArray(P);
if P=nil then
break; // invalid content
end;
end;
while not (P^ in [#0,',','}']) do inc(P);
if P^<>',' then break;
repeat inc(P) until (P^>' ') or (P^=#0);
until false;
end;
end;
result := nil;
end;
function JsonObjectByPath(JsonObject,PropPath: PUTF8Char): PUTF8Char;
var objName: RawUTF8;
begin
result := nil;
if (JsonObject=nil) or (PropPath=nil) then
exit;
repeat
GetNextItem(PropPath,'.',objName);
if objName='' then
exit;
JsonObject := JsonObjectItem(JsonObject,objName);
if JsonObject=nil then
exit;
until PropPath=nil; // found full name scope
result := JsonObject;
end;
function JsonObjectsByPath(JsonObject,PropPath: PUTF8Char): RawUTF8;
var itemName,objName,propNameFound,objPath: RawUTF8;
start,ending,obj: PUTF8Char;
WR: TTextWriter;
temp: TTextWriterStackBuffer;
procedure AddFromStart(const name: RaWUTF8);
begin
start := GotoNextNotSpace(start);
ending := GotoEndJSONItem(start);
if ending=nil then
exit;
if WR=nil then begin
WR := TTextWriter.CreateOwnedStream(temp);
WR.Add('{');
end else
WR.Add(',');
WR.AddFieldName(name);
while (ending>start) and (ending[-1]<=' ') do dec(ending); // trim right
WR.AddNoJSONEscape(start,ending-start);
end;
begin
result := '';
if (JsonObject=nil) or (PropPath=nil) then
exit;
WR := nil;
try
repeat
GetNextItem(PropPath,',',itemName);
if itemName='' then
break;
if itemName[length(itemName)]<>'*' then begin
start := JsonObjectByPath(JsonObject,pointer(itemName));
if start<>nil then
AddFromStart(itemName);
end else begin
objPath := '';
obj := pointer(itemName);
repeat
GetNextItem(obj,'.',objName);
if objName='' then
exit;
propNameFound := '';
JsonObject := JsonObjectItem(JsonObject,objName,@propNameFound);
if JsonObject=nil then
exit;
if obj=nil then begin // found full name scope
start := JsonObject;
repeat
AddFromStart(objPath+propNameFound);
ending := GotoNextNotSpace(ending);
if ending^<>',' then
break;
propNameFound := '';
start := JsonObjectItem(GotoNextNotSpace(ending+1),objName,@propNameFound);
until start=nil;
break;
end else
objPath := objPath+objName+'.';
until false;
end;
until PropPath=nil;
if WR<>nil then begin
WR.Add('}');
WR.SetText(result);
end;
finally
WR.Free;
end;
end;
function JSONObjectAsJSONArrays(JSON: PUTF8Char; out keys,values: RawUTF8): boolean;
var wk,wv: TTextWriter;
kb,ke,vb,ve: PUTF8Char;
temp1,temp2: TTextWriterStackBuffer;
begin
result := false;
if (JSON=nil) or (JSON^<>'{') then
exit;
wk := TTextWriter.CreateOwnedStream(temp1);
wv := TTextWriter.CreateOwnedStream(temp2);
try
wk.Add('[');
wv.Add('[');
kb := JSON+1;
repeat
ke := GotoEndJSONItem(kb);
if (ke=nil) or (ke^<>':') then
exit; // invalid input content
vb := ke+1;
ve := GotoEndJSONItem(vb);
if (ve=nil) or not(ve^ in [',','}']) then
exit;
wk.AddNoJSONEscape(kb,ke-kb);
wk.Add(',');
wv.AddNoJSONEscape(vb,ve-vb);
wv.Add(',');
kb := ve+1;
until ve^='}';
wk.CancelLastComma;
wk.Add(']');
wk.SetText(keys);
wv.CancelLastComma;
wv.Add(']');
wv.SetText(values);
result := true;
finally
wv.Free;
wk.Free;
end;
end;
function TryRemoveComment(P: PUTF8Char): PUTF8Char; {$ifdef HASINLINE}inline;{$endif}
begin
result := P + 1;
case result^ of
'/': begin // this is // comment - replace by ' '
dec(result);
repeat
result^ := ' ';
inc(result)
until result^ in [#0, #10, #13];
if result^<>#0 then inc(result);
end;
'*': begin // this is /* comment - replace by ' ' but keep CRLF
result[-1] := ' ';
repeat
if not(result^ in [#10, #13]) then
result^ := ' '; // keep CRLF for correct line numbering (e.g. for error)
inc(result);
if PWord(result)^=ord('*')+ord('/')shl 8 then begin
PWord(result)^ := $2020;
inc(result,2);
break;
end;
until result^=#0;
end;
end;
end;
procedure RemoveCommentsFromJSON(P: PUTF8Char);
var PComma: PUTF8Char;
begin // replace comments by ' ' characters which will be ignored by parser
if P<>nil then
while P^<>#0 do begin
case P^ of
'"': begin
P := GotoEndOfJSONString(P);
if P^<>'"' then
exit else
Inc(P);
end;
'/': P := TryRemoveComment(P);
',': begin // replace trailing comma by space for strict JSON parsers
PComma := P;
repeat inc(P) until (P^>' ') or (P^=#0);
if P^='/' then
P := TryRemoveComment(P);
while (P^<=' ') and (P^<>#0) do inc(P);
if P^ in ['}', ']'] then
PComma^ := ' '; // see https://github.com/synopse/mORMot/pull/349
end;
else
inc(P);
end;
end;
end;
procedure JSONBufferToXML(P: PUTF8Char; const Header,NameSpace: RawUTF8;
out result: RawUTF8);
var i,j,L: integer;
temp: TTextWriterStackBuffer;
begin
if P=nil then
result := Header else
with TTextWriter.CreateOwnedStream(temp) do
try
AddNoJSONEscape(pointer(Header),length(Header));
L := length(NameSpace);
if L<>0 then
AddNoJSONEscape(pointer(NameSpace),L);
AddJSONToXML(P);
if L<>0 then
for i := 1 to L do
if NameSpace[i]='<' then begin
for j := i+1 to L do
if NameSpace[j] in [' ','>'] then begin
Add('<','/');
AddStringCopy(NameSpace,i+1,j-i-1);
Add('>');
break;
end;
break;
end;
SetText(result);
finally
Free;
end;
end;
function JSONToXML(const JSON: RawUTF8; const Header: RawUTF8;
const NameSpace: RawUTF8): RawUTF8;
var tmp: TSynTempBuffer;
begin
tmp.Init(JSON);
try
JSONBufferToXML(tmp.buf,Header,NameSpace,result);
finally
tmp.Done;
end;
end;
procedure JSONBufferReformat(P: PUTF8Char; out result: RawUTF8;
Format: TTextWriterJSONFormat);
var temp: array[word] of byte; // 64KB buffer
begin
if P<>nil then
with TTextWriter.CreateOwnedStream(@temp,SizeOf(temp)) do
try
AddJSONReformat(P,Format,nil);
SetText(result);
finally
Free;
end;
end;
function JSONReformat(const JSON: RawUTF8; Format: TTextWriterJSONFormat): RawUTF8;
var tmp: TSynTempBuffer;
begin
tmp.Init(JSON);
try
JSONBufferReformat(tmp.buf,result,Format);
finally
tmp.Done;
end;
end;
function JSONBufferReformatToFile(P: PUTF8Char; const Dest: TFileName;
Format: TTextWriterJSONFormat): boolean;
var F: TFileStream;
temp: array[word] of word; // 128KB
begin
try
F := TFileStream.Create(Dest,fmCreate);
try
with TTextWriter.Create(F,@temp,SizeOf(temp)) do
try
AddJSONReformat(P,Format,nil);
FlushFinal;
finally
Free;
end;
result := true;
finally
F.Free;
end;
except
on Exception do
result := false;
end;
end;
function JSONReformatToFile(const JSON: RawUTF8; const Dest: TFileName;
Format: TTextWriterJSONFormat=jsonHumanReadable): boolean;
var tmp: TSynTempBuffer;
begin
tmp.Init(JSON);
try
result := JSONBufferReformatToFile(tmp.buf,Dest,Format);
finally
tmp.Done;
end;
end;
procedure KB(bytes: Int64; out result: TShort16; nospace: boolean);
type TUnits = (kb,mb,gb,tb,pb,eb,b);
const TXT: array[boolean,TUnits] of RawUTF8 =
((' KB',' MB',' GB',' TB',' PB',' EB','% B'), ('KB','MB','GB','TB','PB','EB','%B'));
var hi,rem: cardinal;
u: TUnits;
begin
if bytes<1 shl 10-(1 shl 10) div 10 then begin
FormatShort16(TXT[nospace,b],[integer(bytes)],result);
exit;
end;
if bytes<1 shl 20-(1 shl 20) div 10 then begin
u := kb;
rem := bytes;
hi := bytes shr 10;
end else
if bytes<1 shl 30-(1 shl 30) div 10 then begin
u := mb;
rem := bytes shr 10;
hi := bytes shr 20;
end else
if bytes<Int64(1) shl 40-(Int64(1) shl 40) div 10 then begin
u := gb;
rem := bytes shr 20;
hi := bytes shr 30;
end else
if bytes<Int64(1) shl 50-(Int64(1) shl 50) div 10 then begin
u := tb;
rem := bytes shr 30;
hi := bytes shr 40;
end else
if bytes<Int64(1) shl 60-(Int64(1) shl 60) div 10 then begin
u := pb;
rem := bytes shr 40;
hi := bytes shr 50;
end else begin
u := eb;
rem := bytes shr 50;
hi := bytes shr 60;
end;
rem := rem and 1023;
if rem<>0 then
rem := rem div 102;
if rem=10 then begin
rem := 0;
inc(hi); // round up as expected by (most) human beings
end;
if rem<>0 then
FormatShort16('%.%%',[hi,rem,TXT[nospace,u]],result) else
FormatShort16('%%',[hi,TXT[nospace,u]],result);
end;
function KB(bytes: Int64): TShort16;
begin
KB(bytes,result,{nospace=}false);
end;
function KBNoSpace(bytes: Int64): TShort16;
begin
KB(bytes,result,{nospace=}true);
end;
function KB(bytes: Int64; nospace: boolean): TShort16;
begin
KB(bytes,result,nospace);
end;
function KB(const buffer: RawByteString): TShort16;
begin
KB(length(buffer),result,{nospace=}false);
end;
procedure KBU(bytes: Int64; var result: RawUTF8);
var tmp: TShort16;
begin
KB(bytes,tmp,{nospace=}false);
FastSetString(result,@tmp[1],ord(tmp[0]));
end;
function IntToThousandString(Value: integer; const ThousandSep: TShort4): shortstring;
var i,L,Len: cardinal;
begin
str(Value,result);
L := length(result);
Len := L+1;
if Value<0 then
dec(L,2) else // ignore '-' sign
dec(L);
for i := 1 to L div 3 do
insert(ThousandSep,result,Len-i*3);
end;
function MicroSecToString(Micro: QWord): TShort16;
begin
MicroSecToString(Micro,result);
end;
procedure MicroSecToString(Micro: QWord; out result: TShort16);
procedure TwoDigitToString(value: cardinal; const u: shortstring; var result: TShort16);
var d100: TDiv100Rec;
begin
if value<100 then
FormatShort16('0.%%',[UInt2DigitsToShortFast(value),u],result) else begin
Div100(value,d100);
if d100.m=0 then
FormatShort16('%%',[d100.d,u],result) else
FormatShort16('%.%%',[d100.d,UInt2DigitsToShortFast(d100.m),u],result);
end;
end;
procedure TimeToString(value: cardinal; const u: shortstring; var result: TShort16);
var d: cardinal;
begin
d := value div 60;
FormatShort16('%%%',[d,u,UInt2DigitsToShortFast(value-(d*60))],result);
end;
begin
if Int64(Micro)<=0 then
result := '0us' else
if Micro<1000 then
FormatShort16('%us',[Micro],result) else
if Micro<1000000 then
TwoDigitToString({$ifdef CPU32}PCardinal(@Micro)^{$else}Micro{$endif} div 10,'ms',result) else
if Micro<60000000 then
TwoDigitToString({$ifdef CPU32}PCardinal(@Micro)^{$else}Micro{$endif} div 10000,'s',result) else
if Micro<QWord(3600000000) then
TimeToString({$ifdef CPU32}PCardinal(@Micro)^{$else}Micro{$endif} div 1000000,'m',result) else
if Micro<QWord(86400000000*2) then
TimeToString(Micro div 60000000,'h',result) else
FormatShort16('%d',[Micro div QWord(86400000000)],result)
end;
function IsInitializedCriticalSection(const CS: TRTLCriticalSection): Boolean;
begin
result := not IsZero(PHash128(@CS)^); // minimum size is 24 bytes = 192 bits
end;
procedure InitializeCriticalSectionIfNeededAndEnter(var CS: TRTLCriticalSection);
begin
if IsZero(PHash128(@CS)^) then
InitializeCriticalSection(CS);
EnterCriticalSection(CS);
end;
procedure DeleteCriticalSectionIfNeeded(var CS: TRTLCriticalSection);
begin
if not IsZero(PHash128(@CS)^) then
DeleteCriticalSection(CS);
end;
{ ******************* process monitoring / statistics ********************** }
{ TPrecisionTimer }
procedure TPrecisionTimer.Init;
begin
FillCharFast(self,SizeOf(self),0);
end;
procedure TPrecisionTimer.Start;
begin
FillCharFast(self,SizeOf(self),0);
{$ifdef LINUX}QueryPerformanceMicroSeconds{$else}QueryPerformanceCounter{$endif}(fStart);
end;
function TPrecisionTimer.Started: boolean;
begin
result := (fStart<>0) or (fTime<>0);
end;
procedure TPrecisionTimer.Resume;
begin
if fStart=0 then
{$ifdef LINUX}QueryPerformanceMicroSeconds{$else}QueryPerformanceCounter{$endif}(fStart);
end;
procedure TPrecisionTimer.Pause;
begin
if fStart=0 then
exit;
{$ifdef LINUX}QueryPerformanceMicroSeconds{$else}QueryPerformanceCounter{$endif}(fStop);
FromExternalQueryPerformanceCounters(fStop-fStart);
inc(fPauseCount);
end;
procedure TPrecisionTimer.FromExternalMicroSeconds(const MicroSeconds: QWord);
begin
fLastTime := MicroSeconds;
inc(fTime,MicroSeconds);
fStart := 0; // indicates time has been computed
end;
function TPrecisionTimer.FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord;
begin // mimics Pause from already known elapsed time
{$ifdef LINUX}
FromExternalMicroSeconds(CounterDiff);
{$else}
if fWinFreq=0 then
QueryPerformanceFrequency(fWinFreq);
if fWinFreq<>0 then
FromExternalMicroSeconds((CounterDiff*1000000)div PQWord(@fWinFreq)^);
{$endif LINUX}
result := fLastTime;
end;
function TPrecisionTimer.Stop: TShort16;
begin
if fStart<>0 then
Pause;
MicroSecToString(fTime,result);
end;
function TPrecisionTimer.StopInMicroSec: TSynMonitorTotalMicroSec;
begin
if fStart<>0 then
Pause;
result := fTime;
end;
function TPrecisionTimer.Time: TShort16;
begin
if fStart<>0 then
Pause;
MicroSecToString(fTime,result);
end;
function TPrecisionTimer.LastTime: TShort16;
begin
if fStart<>0 then
Pause;
MicroSecToString(fLastTime,result);
end;
function TPrecisionTimer.ByCount(Count: QWord): TShort16;
begin
if Count=0 then // avoid div per 0 exception
result := '0' else begin
if fStart<>0 then
Pause;
MicroSecToString(fTime div Count,result);
end;
end;
function TPrecisionTimer.PerSec(const Count: QWord): QWord;
begin
if fStart<>0 then
Pause;
if fTime<=0 then // avoid negative value in case of incorrect Start/Stop sequence
result := 0 else // avoid div per 0 exception
result := (Count*1000000) div fTime;
end;
function TPrecisionTimer.SizePerSec(Size: QWord): shortstring;
begin
FormatShort('% in % i.e. %/s',[KB(Size),Stop,KB(PerSec(Size))],result);
end;
type
/// a class used internaly by TPrecisionTimer.ProfileMethod
TPrecisionTimerProfiler = class(TInterfacedObject)
protected
fTimer: PPrecisionTimer;
public
constructor Create(aTimer: PPrecisionTimer);
destructor Destroy; override;
end;
constructor TPrecisionTimerProfiler.Create(aTimer: PPrecisionTimer);
begin
fTimer := aTimer;
end;
destructor TPrecisionTimerProfiler.Destroy;
begin
if fTimer<>nil then
fTimer^.Pause;
inherited;
end;
function TPrecisionTimer.ProfileCurrentMethod: IUnknown;
begin
Resume;
result := TPrecisionTimerProfiler.Create(@self);
end;
{ TLocalPrecisionTimer }
function TLocalPrecisionTimer.ByCount(Count: cardinal): RawUTF8;
begin
result := fTimer.ByCount(Count);
end;
procedure TLocalPrecisionTimer.Pause;
begin
fTimer.Pause;
end;
function TLocalPrecisionTimer.PerSec(Count: cardinal): cardinal;
begin
result := fTimer.PerSec(Count);
end;
procedure TLocalPrecisionTimer.Resume;
begin
fTimer.Resume;
end;
procedure TLocalPrecisionTimer.Start;
begin
fTimer.Start;
end;
function TLocalPrecisionTimer.Stop: TShort16;
begin
result := fTimer.Stop;
end;
constructor TLocalPrecisionTimer.CreateAndStart;
begin
inherited;
fTimer.Start;
end;
{ TSynMonitorTime }
function TSynMonitorTime.GetAsText: TShort16;
begin
MicroSecToString(fMicroSeconds,result);
end;
function TSynMonitorTime.PerSecond(const Count: QWord): QWord;
begin
if {$ifdef FPC}Int64(fMicroSeconds){$else}PInt64(@fMicroSeconds)^{$endif}<=0 then
result := 0 else // avoid negative or div per 0
result := (Count*1000000) div fMicroSeconds;
end;
{ TSynMonitorOneTime }
function TSynMonitorOneTime.GetAsText: TShort16;
begin
MicroSecToString(fMicroSeconds,result);
end;
function TSynMonitorOneTime.PerSecond(const Count: QWord): QWord;
begin
if {$ifdef FPC}Int64(fMicroSeconds){$else}PInt64(@fMicroSeconds)^{$endif}<=0 then
result := 0 else
result := (Count*QWord(1000000)) div fMicroSeconds;
end;
{ TSynMonitorSizeParent }
constructor TSynMonitorSizeParent.Create(aTextNoSpace: boolean);
begin
inherited Create;
fTextNoSpace := aTextNoSpace;
end;
{ TSynMonitorSize }
function TSynMonitorSize.GetAsText: TShort16;
begin
KB(fBytes,result,fTextNoSpace);
end;
{ TSynMonitorOneSize }
function TSynMonitorOneSize.GetAsText: TShort16;
begin
KB(fBytes,result,fTextNoSpace);
end;
{ TSynMonitorThroughput }
function TSynMonitorThroughput.GetAsText: TShort16;
begin
FormatShort16('%/s',[KB(fBytesPerSec,fTextNoSpace)],result);
end;
{ TSynMonitor }
constructor TSynMonitor.Create;
begin
inherited Create;
fTotalTime := TSynMonitorTime.Create;
fLastTime := TSynMonitorOneTime.Create;
fMinimalTime := TSynMonitorOneTime.Create;
fAverageTime := TSynMonitorOneTime.Create;
fMaximalTime := TSynMonitorOneTime.Create;
end;
constructor TSynMonitor.Create(const aName: RawUTF8);
begin
Create;
fName := aName;
end;
destructor TSynMonitor.Destroy;
begin
fMaximalTime.Free;
fAverageTime.Free;
fMinimalTime.Free;
fLastTime.Free;
fTotalTime.Free;
inherited Destroy;
end;
procedure TSynMonitor.Lock;
begin
fSafe^.Lock;
end;
procedure TSynMonitor.UnLock;
begin
fSafe^.UnLock;
end;
procedure TSynMonitor.Changed;
begin // do nothing by default - overriden classes may track modified changes
end;
procedure TSynMonitor.ProcessStart;
begin
if fProcessing then
raise ESynException.CreateUTF8('Reentrant %.ProcessStart',[self]);
fSafe^.Lock;
try
InternalTimer.Resume;
fTaskStatus := taskNotStarted;
fProcessing := true;
finally
fSafe^.UnLock;
end;
end;
procedure TSynMonitor.ProcessDoTask;
begin
fSafe^.Lock;
try
inc(fTaskCount);
fTaskStatus := taskStarted;
Changed;
finally
fSafe^.UnLock;
end;
end;
procedure TSynMonitor.ProcessStartTask;
begin
if fProcessing then
raise ESynException.CreateUTF8('Reentrant %.ProcessStart',[self]);
fSafe^.Lock;
try
InternalTimer.Resume;
fProcessing := true;
inc(fTaskCount);
fTaskStatus := taskStarted;
Changed;
finally
fSafe^.UnLock;
end;
end;
procedure TSynMonitor.ProcessEnd;
begin
fSafe^.Lock;
try
InternalTimer.Pause;
LockedFromProcessTimer;
finally
fSafe^.UnLock;
end;
end;
procedure TSynMonitor.LockedFromProcessTimer;
begin
fTotalTime.MicroSec := InternalTimer.TimeInMicroSec;
if fTaskStatus=taskStarted then begin
fLastTime.MicroSec := InternalTimer.LastTimeInMicroSec;
if (fMinimalTime.MicroSec=0) or
(InternalTimer.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
fSafe^.Lock;
try // thread-safe ProcessStart+ProcessDoTask+ProcessEnd
inc(fTaskCount);
fTaskStatus := taskStarted;
result := InternalTimer.FromExternalQueryPerformanceCounters(CounterDiff);
LockedFromProcessTimer;
finally
fSafe^.UnLock;
end;
end;
procedure TSynMonitor.FromExternalMicroSeconds(const MicroSecondsElapsed: QWord);
begin
fSafe^.Lock;
try // thread-safe ProcessStart+ProcessDoTask+ProcessEnd
inc(fTaskCount);
fTaskStatus := taskStarted;
InternalTimer.FromExternalMicroSeconds(MicroSecondsElapsed);
LockedFromProcessTimer;
finally
fSafe^.UnLock;
end;
end;
class procedure TSynMonitor.InitializeObjArray(var ObjArr; Count: integer);
var i: integer;
begin
ObjArrayClear(ObjArr);
SetLength(TPointerDynArray(ObjArr),Count);
for i := 0 to Count-1 do
TPointerDynArray(ObjArr)[i] := Create;
end;
procedure TSynMonitor.ProcessError(const info: variant);
begin
fSafe^.Lock;
try
if not VarIsEmptyOrNull(info) then
inc(fInternalErrors);
fLastInternalError := info;
Changed;
finally
fSafe^.UnLock;
end;
end;
procedure TSynMonitor.ProcessErrorFmt(const Fmt: RawUTF8; const Args: array of const);
begin
ProcessError({$ifndef NOVARIANTS}RawUTF8ToVariant{$endif}(FormatUTF8(Fmt,Args)));
end;
procedure TSynMonitor.ProcessErrorRaised(E: Exception);
begin
{$ifndef NOVARIANTS}if E.InheritsFrom(ESynException) then
ProcessError(_ObjFast([E,ObjectToVariant(E,true)])) else{$endif}
ProcessErrorFmt('%: %', [E,E.Message]);
end;
procedure TSynMonitor.ProcessErrorNumber(info: integer);
begin
ProcessError(info);
end;
procedure TSynMonitor.LockedPerSecProperties;
begin
if fTaskCount=0 then
exit; // avoid division per zero
fPerSec := fTotalTime.PerSecond(fTaskCount);
fAverageTime.MicroSec := fTotalTime.MicroSec div fTaskCount;
end;
procedure TSynMonitor.Sum(another: TSynMonitor);
begin
if (self=nil) or (another=nil) then
exit;
fSafe^.Lock;
another.fSafe^.Lock;
try
LockedSum(another);
finally
another.fSafe^.UnLock;
fSafe^.UnLock;
end;
end;
procedure TSynMonitor.LockedSum(another: TSynMonitor);
begin
fTotalTime.MicroSec := fTotalTime.MicroSec+another.fTotalTime.MicroSec;
if (fMinimalTime.MicroSec=0) or
(another.fMinimalTime.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
fSafe^.Lock;
try
W.WriteObject(self);
finally
fSafe^.UnLock;
end;
end;
procedure TSynMonitor.ComputeDetailsTo(W: TTextWriter);
begin
fSafe^.Lock;
try
LockedPerSecProperties; // may not have been calculated after Sum()
WriteDetailsTo(W);
finally
fSafe^.UnLock;
end;
end;
function TSynMonitor.ComputeDetailsJSON: RawUTF8;
var W: TTextWriter;
temp: TTextWriterStackBuffer;
begin
W := DefaultTextWriterSerializer.CreateOwnedStream(temp);
try
ComputeDetailsTo(W);
W.SetText(result);
finally
W.Free;
end;
end;
{$ifndef NOVARIANTS}
function TSynMonitor.ComputeDetails: variant;
begin
_Json(ComputeDetailsJSON,result,JSON_OPTIONS_FAST);
end;
{$endif}
{ TSynMonitorWithSize}
constructor TSynMonitorWithSize.Create;
begin
inherited Create;
fSize := TSynMonitorSize.Create({nospace=}false);
fThroughput := TSynMonitorThroughput.Create({nospace=}false);
end;
destructor TSynMonitorWithSize.Destroy;
begin
inherited Destroy;
fThroughput.Free;
fSize.Free;
end;
procedure TSynMonitorWithSize.LockedPerSecProperties;
begin
inherited LockedPerSecProperties;
fThroughput.BytesPerSec := fTotalTime.PerSecond(fSize.Bytes);
end;
procedure TSynMonitorWithSize.AddSize(const Bytes: QWord);
begin
fSafe^.Lock;
try
fSize.Bytes := fSize.Bytes+Bytes;
finally
fSafe^.UnLock;
end;
end;
procedure TSynMonitorWithSize.LockedSum(another: TSynMonitor);
begin
inherited LockedSum(another);
if another.InheritsFrom(TSynMonitorWithSize) then
AddSize(TSynMonitorWithSize(another).Size.Bytes);
end;
{ TSynMonitorInputOutput }
constructor TSynMonitorInputOutput.Create;
begin
inherited Create;
fInput := TSynMonitorSize.Create({nospace=}false);
fOutput := TSynMonitorSize.Create({nospace=}false);
fInputThroughput := TSynMonitorThroughput.Create({nospace=}false);
fOutputThroughput := TSynMonitorThroughput.Create({nospace=}false);
end;
destructor TSynMonitorInputOutput.Destroy;
begin
fOutputThroughput.Free;
fOutput.Free;
fInputThroughput.Free;
fInput.Free;
inherited Destroy;
end;
procedure TSynMonitorInputOutput.LockedPerSecProperties;
begin
inherited LockedPerSecProperties;
fInputThroughput.BytesPerSec := fTotalTime.PerSecond(fInput.Bytes);
fOutputThroughput.BytesPerSec := fTotalTime.PerSecond(fOutput.Bytes);
end;
procedure TSynMonitorInputOutput.AddSize(const Incoming, Outgoing: QWord);
begin
fSafe^.Lock;
try
fInput.Bytes := fInput.Bytes+Incoming;
fOutput.Bytes := fOutput.Bytes+Outgoing;
finally
fSafe^.UnLock;
end;
end;
procedure TSynMonitorInputOutput.LockedSum(another: TSynMonitor);
begin
inherited LockedSum(another);
if another.InheritsFrom(TSynMonitorInputOutput) then begin
fInput.Bytes := fInput.Bytes+TSynMonitorInputOutput(another).Input.Bytes;
fOutput.Bytes := fOutput.Bytes+TSynMonitorInputOutput(another).Output.Bytes;
end;
end;
{ TSynMonitorServer }
procedure TSynMonitorServer.ClientConnect;
begin
if self=nil then
exit;
fSafe^.Lock;
try
inc(fClientsCurrent);
if fClientsCurrent>fClientsMax then
fClientsMax := fClientsCurrent;
Changed;
finally
fSafe^.UnLock;
end;
end;
procedure TSynMonitorServer.ClientDisconnect;
begin
if self=nil then
exit;
fSafe^.Lock;
try
if fClientsCurrent>0 then
dec(fClientsCurrent);
Changed;
finally
fSafe^.UnLock;
end;
end;
procedure TSynMonitorServer.ClientDisconnectAll;
begin
if self=nil then
exit;
fSafe^.Lock;
try
fClientsCurrent := 0;
Changed;
finally
fSafe^.UnLock;
end;
end;
function TSynMonitorServer.GetClientsCurrent: TSynMonitorOneCount;
begin
if self=nil then begin
result := 0;
exit;
end;
fSafe^.Lock;
try
result := fClientsCurrent;
finally
fSafe^.UnLock;
end;
end;
function TSynMonitorServer.AddCurrentRequestCount(diff: integer): integer;
begin
if self=nil then begin
result := 0;
exit;
end;
fSafe^.Lock;
try
inc(fCurrentRequestCount,diff);
result := fCurrentRequestCount;
finally
fSafe^.UnLock;
end;
end;
{ ******************* cross-cutting classes and functions ***************** }
{ TSynInterfacedObject }
function TSynInterfacedObject._AddRef: {$ifdef FPC}longint{$else}integer{$endif};
begin
result := VirtualAddRef;
end;
function TSynInterfacedObject._Release: {$ifdef FPC}longint{$else}integer{$endif};
begin
result := VirtualRelease;
end;
{$ifdef FPC}
function TSynInterfacedObject.QueryInterface(
{$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID;
out Obj): longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
{$else}
function TSynInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult;
{$endif}
begin
result := VirtualQueryInterface(IID,Obj);
end;
function TSynInterfacedObject.VirtualQueryInterface(const IID: TGUID; out Obj): HResult;
begin
result := E_NOINTERFACE;
end;
{$ifdef CPUINTEL}
{$ifndef DELPHI5OROLDER}
{ TSynFPUException }
function TSynFPUException.VirtualAddRef: integer;
begin
if fRefCount=0 then begin
{$ifndef CPU64}
fSaved8087 := Get8087CW;
Set8087CW(fExpected8087); // set FPU exceptions mask
{$else}
fSavedMXCSR := GetMXCSR;
SetMXCSR(fExpectedMXCSR); // set FPU exceptions mask
{$endif}
end;
inc(fRefCount);
result := 1; // should never be 0 (mark release of TSynFPUException instance)
end;
function TSynFPUException.VirtualRelease: integer;
begin
dec(fRefCount);
if fRefCount=0 then
{$ifndef CPU64}
Set8087CW(fSaved8087);
{$else}
SetMXCSR(fSavedMXCSR);
{$endif}
result := 1; // should never be 0 (mark release of TSynFPUException instance)
end;
threadvar
GlobalSynFPUExceptionDelphi,
GlobalSynFPUExceptionLibrary: TSynFPUException;
{$ifndef CPU64}
constructor TSynFPUException.Create(Expected8087Flag: word);
begin // $1372=Delphi $137F=library (mask all exceptions)
inherited Create;
fExpected8087 := Expected8087Flag;
end;
{$else}
constructor TSynFPUException.Create(ExpectedMXCSR: word);
begin // $1920=Delphi $1FA0=library (mask all exceptions)
inherited Create;
fExpectedMXCSR := ExpectedMXCSR;
end;
{$endif}
class function TSynFPUException.ForLibraryCode: IUnknown;
var obj: TSynFPUException;
begin
result := GlobalSynFPUExceptionLibrary;
if result<>nil then
exit;
{$ifndef CPU64}
obj := TSynFPUException.Create($137F);
{$else}
obj := TSynFPUException.Create($1FA0);
{$endif}
GarbageCollector.Add(obj);
GlobalSynFPUExceptionLibrary := obj;
result := obj;
end;
class function TSynFPUException.ForDelphiCode: IUnknown;
var obj: TSynFPUException;
begin
result := GlobalSynFPUExceptionDelphi;
if result<>nil then
exit;
{$ifndef CPU64}
obj := TSynFPUException.Create($1372);
{$else}
obj := TSynFPUException.Create($1920);
{$endif}
GarbageCollector.Add(obj);
GlobalSynFPUExceptionDelphi := obj;
result := obj;
end;
{$endif DELPHI5OROLDER}
{$endif CPUINTEL}
{ TAutoFree }
constructor TAutoFree.Create(var localVariable; obj: TObject);
begin
fObject := obj;
TObject(localVariable) := obj;
end;
class function TAutoFree.One(var localVariable; obj: TObject): IAutoFree;
begin
result := Create(localVariable,obj);
end;
class function TAutoFree.Several(const varObjPairs: array of pointer): IAutoFree;
begin
result := Create(varObjPairs);
end;
constructor TAutoFree.Create(const varObjPairs: array of pointer);
var n,i: integer;
begin
n := length(varObjPairs);
if (n=0) or (n and 1=1) then
exit;
n := n shr 1;
if n=0 then
exit;
SetLength(fObjectList,n);
for i := 0 to n-1 do begin
fObjectList[i] := varObjPairs[i*2+1];
PPointer(varObjPairs[i*2])^ := fObjectList[i];
end;
end;
procedure TAutoFree.Another(var localVariable; obj: TObject);
var n: integer;
begin
n := length(fObjectList);
SetLength(fObjectList,n+1);
fObjectList[n] := obj;
TObject(localVariable) := obj;
end;
destructor TAutoFree.Destroy;
var i: integer;
begin
if fObjectList<>nil then
for i := high(fObjectList) downto 0 do // release FILO
fObjectList[i].Free;
fObject.Free;
inherited;
end;
{ TAutoLocker }
constructor TAutoLocker.Create;
begin
fSafe.Init;
end;
destructor TAutoLocker.Destroy;
begin
fSafe.Done;
inherited;
end;
function TAutoLocker.ProtectMethod: IUnknown;
begin
result := TAutoLock.Create(@fSafe);
end;
procedure TAutoLocker.Enter;
begin
fSafe.Lock;
end;
procedure TAutoLocker.Leave;
begin
fSafe.UnLock;
end;
function TAutoLocker.Safe: PSynLocker;
begin
result := @fSafe;
end;
{$ifndef DELPHI5OROLDER} // internal error C3517 under Delphi 5 :(
{$ifndef NOVARIANTS}
{ TLockedDocVariant }
constructor TLockedDocVariant.Create;
begin
Create(JSON_OPTIONS_FAST);
end;
constructor TLockedDocVariant.Create(FastStorage: boolean);
begin
Create(JSON_OPTIONS[FastStorage]);
end;
constructor TLockedDocVariant.Create(options: TDocVariantOptions);
begin
fLock := TAutoLocker.Create;
fValue.Init(options);
end;
destructor TLockedDocVariant.Destroy;
begin
inherited;
fLock.Free;
end;
function TLockedDocVariant.Lock: TAutoLocker;
begin
result := fLock;
end;
function TLockedDocVariant.Exists(const Name: RawUTF8; out Value: Variant): boolean;
var i: integer;
begin
fLock.Enter;
try
i := fValue.GetValueIndex(Name);
if i<0 then
result := false else begin
Value := fValue.Values[i];
result := true;
end;
finally
fLock.Leave;
end;
end;
function TLockedDocVariant.ExistsOrLock(const Name: RawUTF8; out Value: Variant): boolean;
var i: integer;
begin
result := true;
fLock.Enter;
try
i := fValue.GetValueIndex(Name);
if i<0 then
result := false else
Value := fValue.Values[i];
finally
if result then
fLock.Leave;
end;
end;
procedure TLockedDocVariant.ReplaceAndUnlock(
const Name: RawUTF8; const Value: Variant; out LocalValue: Variant);
begin // caller made fLock.Enter
try
SetValue(Name,Value);
LocalValue := Value;
finally
fLock.Leave;
end;
end;
function TLockedDocVariant.AddExistingPropOrLock(const Name: RawUTF8;
var Obj: variant): boolean;
var i: integer;
begin
result := true;
fLock.Enter;
try
i := fValue.GetValueIndex(Name);
if i<0 then
result := false else
_ObjAddProps([Name,fValue.Values[i]],Obj);
finally
if result then
fLock.Leave;
end;
end;
procedure TLockedDocVariant.AddNewPropAndUnlock(const Name: RawUTF8;
const Value: variant;
var Obj: variant);
begin // caller made fLock.Enter
try
SetValue(Name,Value);
_ObjAddProps([Name,Value],Obj);
finally
fLock.Leave;
end;
end;
function TLockedDocVariant.AddExistingProp(const Name: RawUTF8;
var Obj: variant): boolean;
var i: integer;
begin
result := true;
fLock.Enter;
try
i := fValue.GetValueIndex(Name);
if i<0 then
result := false else
_ObjAddProps([Name,fValue.Values[i]],Obj);
finally
fLock.Leave;
end;
end;
procedure TLockedDocVariant.AddNewProp(const Name: RawUTF8;
const Value: variant; var Obj: variant);
begin
fLock.Enter;
try
SetValue(Name,Value);
_ObjAddProps([Name,Value],Obj);
finally
fLock.Leave;
end;
end;
function TLockedDocVariant.GetValue(const Name: RawUTF8): Variant;
begin
fLock.Enter;
try
fValue.RetrieveValueOrRaiseException(pointer(Name),length(Name),
dvoNameCaseSensitive in fValue.Options,result,false);
finally
fLock.Leave;
end;
end;
procedure TLockedDocVariant.SetValue(const Name: RawUTF8;
const Value: Variant);
begin
fLock.Enter;
try
fValue.AddOrUpdateValue(Name,Value);
finally
fLock.Leave;
end;
end;
procedure TLockedDocVariant.AddItem(const Value: variant);
begin
fLock.Enter;
try
fValue.AddItem(Value);
finally
fLock.Leave;
end;
end;
function TLockedDocVariant.Copy: variant;
begin
VarClear(result);
fLock.Enter;
try
TDocVariantData(result).InitCopy(variant(fValue),JSON_OPTIONS_FAST);
finally
fLock.Leave;
end;
end;
procedure TLockedDocVariant.Clear;
var opt: TDocVariantOptions;
begin
fLock.Enter;
try
opt := fValue.Options;
fValue.Clear;
fValue.Init(opt);
finally
fLock.Leave;
end;
end;
function TLockedDocVariant.ToJSON(HumanReadable: boolean): RawUTF8;
var tmp: RawUTF8;
begin
fLock.Enter;
try
VariantSaveJSON(variant(fValue),twJSONEscape,tmp);
finally
fLock.Leave;
end;
if HumanReadable then
JSONBufferReformat(pointer(tmp),result) else
result := tmp;
end;
{$endif NOVARIANTS}
{$endif DELPHI5OROLDER}
function GetDelphiCompilerVersion: RawUTF8;
begin
result :=
{$ifdef FPC}
'Free Pascal'
{$ifdef VER2_6_4}+' 2.6.4'{$endif}
{$ifdef VER3_0_0}+' 3.0.0'{$endif}
{$ifdef VER3_0_1}+' 3.0.1'{$endif}
{$ifdef VER3_0_2}+' 3.0.2'{$endif}
{$ifdef VER3_1_1}+' 3.1.1'{$endif}
{$ifdef VER3_2} +' 3.2' {$endif}
{$ifdef VER3_3_1}+' 3.3.1'{$endif}
{$else}
{$ifdef VER130} 'Delphi 5'{$endif}
{$ifdef CONDITIONALEXPRESSIONS} // Delphi 6 or newer
{$if defined(KYLIX3)}'Kylix 3'
{$elseif defined(VER140)}'Delphi 6'
{$elseif defined(VER150)}'Delphi 7'
{$elseif defined(VER160)}'Delphi 8'
{$elseif defined(VER170)}'Delphi 2005'
{$elseif defined(VER185)}'Delphi 2007'
{$elseif defined(VER180)}'Delphi 2006'
{$elseif defined(VER200)}'Delphi 2009'
{$elseif defined(VER210)}'Delphi 2010'
{$elseif defined(VER220)}'Delphi XE'
{$elseif defined(VER230)}'Delphi XE2'
{$elseif defined(VER240)}'Delphi XE3'
{$elseif defined(VER250)}'Delphi XE4'
{$elseif defined(VER260)}'Delphi XE5'
{$elseif defined(VER265)}'AppMethod 1'
{$elseif defined(VER270)}'Delphi XE6'
{$elseif defined(VER280)}'Delphi XE7'
{$elseif defined(VER290)}'Delphi XE8'
{$elseif defined(VER300)}'Delphi 10 Seattle'
{$elseif defined(VER310)}'Delphi 10.1 Berlin'
{$elseif defined(VER320)}'Delphi 10.2 Tokyo'
{$elseif defined(VER330)}'Delphi 10.3 Rio'
{$elseif defined(VER340)}'Delphi 10.4 Sydney'
{$elseif defined(VER350)}'Delphi 11 Alexandria'
{$elseif defined(VER360)}'Delphi 11.1 Next'
{$ifend}
{$endif CONDITIONALEXPRESSIONS}
{$endif FPC}
{$ifdef CPU64} +' 64 bit' {$else} +' 32 bit' {$endif}
end;
{ TRawUTF8List }
constructor TRawUTF8List.Create(aOwnObjects, aNoDuplicate, aCaseSensitive: boolean);
begin
if aOwnObjects then
include(fFlags,fObjectsOwned);
if aNoDuplicate then
include(fFlags,fNoDuplicate);
if aCaseSensitive then
include(fFlags,fCaseSensitive);
Create(fFlags);
end;
constructor TRawUTF8List.Create(aFlags: TRawUTF8ListFlags);
begin
fNameValueSep := '=';
fFlags := aFlags;
fValues.InitSpecific(TypeInfo(TRawUTF8DynArray),fValue,djRawUTF8,@fCount,
not (fCaseSensitive in aFlags));
fSafe.Init;
end;
destructor TRawUTF8List.Destroy;
begin
SetCapacity(0);
inherited;
fSafe.Done;
end;
procedure TRawUTF8List.SetCaseSensitive(Value: boolean);
begin
if (self=nil) or (fCaseSensitive in fFlags=Value) then
exit;
fSafe.Lock;
try
if Value then
include(fFlags,fCaseSensitive) else
exclude(fFlags,fCaseSensitive);
fValues.Hasher.InitSpecific(@fValues,djRawUTF8,not Value);
Changed;
finally
fSafe.UnLock;
end;
end;
procedure TRawUTF8List.SetCapacity(const capa: PtrInt);
begin
if self<>nil then begin
fSafe.Lock;
try
if capa<=0 then begin // clear
if fObjects<>nil then begin
if fObjectsOwned in fFlags then
RawObjectsClear(pointer(fObjects),fCount);
fObjects := nil;
end;
fValues.Clear;
if fNoDuplicate in fFlags then
fValues.Hasher.Clear;
Changed;
end else begin // resize
if capa<fCount then begin // resize down
if fObjects<>nil then begin
if fObjectsOwned in fFlags then
RawObjectsClear(@fObjects[capa],fCount-capa-1);
SetLength(fObjects,capa);
end;
fValues.Count := capa;
if fNoDuplicate in fFlags then
fValues.ReHash;
Changed;
end;
if capa>length(fValue) then begin // resize up
SetLength(fValue,capa);
if fObjects<>nil then
SetLength(fObjects,capa);
end;
end;
finally
fSafe.UnLock;
end;
end;
end;
function TRawUTF8List.Add(const aText: RawUTF8; aRaiseExceptionIfExisting: boolean): PtrInt;
begin
result := AddObject(aText,nil,aRaiseExceptionIfExisting);
end;
function TRawUTF8List.AddObject(const aText: RawUTF8; aObject: TObject;
aRaiseExceptionIfExisting: boolean; aFreeAndReturnExistingObject: PPointer): PtrInt;
var added: boolean;
obj: TObject;
begin
result := -1;
if self=nil then
exit;
fSafe.Lock;
try
if fNoDuplicate in fFlags then begin
result := fValues.FindHashedForAdding(aText,added,{noadd=}true);
if not added then begin
obj := GetObject(result);
if (obj=aObject) and (obj<>nil) then
exit; // found identical aText/aObject -> behave as if added
if aFreeAndReturnExistingObject<>nil then begin
aObject.Free;
aFreeAndReturnExistingObject^ := obj;
end;
if aRaiseExceptionIfExisting then
raise ESynException.CreateUTF8('%.Add duplicate [%]',[self,aText]);
result := -1;
exit;
end;
end;
result := fValues.Add(aText);
if (fObjects<>nil) or (aObject<>nil) then begin
if result>=length(fObjects) then
SetLength(fObjects,length(fValue)); // same capacity
if aObject<>nil then
fObjects[result] := aObject;
end;
if Assigned(fOnChange) then
Changed;
finally
fSafe.UnLock;
end;
end;
procedure TRawUTF8List.AddObjectUnique(const aText: RawUTF8;
aObjectToAddOrFree: PPointer);
begin
if fNoDuplicate in fFlags then
AddObject(aText,aObjectToAddOrFree^,{raiseexc=}false,
{freeandreturnexisting=}aObjectToAddOrFree);
end;
procedure TRawUTF8List.AddRawUTF8List(List: TRawUTF8List);
var i: PtrInt;
begin
if List<>nil then begin
BeginUpdate; // includes Safe.Lock
try
for i := 0 to List.fCount-1 do
AddObject(List.fValue[i],List.GetObject(i));
finally
EndUpdate;
end;
end;
end;
procedure TRawUTF8List.BeginUpdate;
begin
if InterLockedIncrement(fOnChangeLevel)>1 then
exit;
fSafe.Lock;
fOnChangeBackupForBeginUpdate := fOnChange;
fOnChange := OnChangeHidden;
exclude(fFlags,fOnChangeTrigerred);
end;
procedure TRawUTF8List.EndUpdate;
begin
if (fOnChangeLevel<=0) or (InterLockedDecrement(fOnChangeLevel)>0) then
exit; // allows nested BeginUpdate..EndUpdate calls
fOnChange := fOnChangeBackupForBeginUpdate;
if (fOnChangeTrigerred in fFlags) and Assigned(fOnChange) then
Changed;
exclude(fFlags,fOnChangeTrigerred);
fSafe.UnLock;
end;
procedure TRawUTF8List.Changed;
begin
if Assigned(fOnChange) then
try
fOnChange(self);
except // ignore any exception in user code (may not trigger fSafe.UnLock)
end;
end;
procedure TRawUTF8List.Clear;
begin
SetCapacity(0); // will also call Changed
end;
procedure TRawUTF8List.InternalDelete(Index: PtrInt);
begin // caller ensured Index is correct
fValues.Delete(Index); // includes dec(fCount)
if PtrUInt(Index)<PtrUInt(length(fObjects)) then begin
if fObjectsOwned in fFlags then
fObjects[Index].Free;
if fCount>Index then
MoveFast(fObjects[Index+1],fObjects[Index],(fCount-Index)*SizeOf(pointer));
fObjects[fCount] := nil;
end;
if Assigned(fOnChange) then
Changed;
end;
procedure TRawUTF8List.Delete(Index: PtrInt);
begin
if (self<>nil) and (PtrUInt(Index)<PtrUInt(fCount)) then
if fNoDuplicate in fFlags then // force update the hash table
Delete(fValue[Index]) else
InternalDelete(Index);
end;
function TRawUTF8List.Delete(const aText: RawUTF8): PtrInt;
begin
fSafe.Lock;
try
if fNoDuplicate in fFlags then
result := fValues.FindHashedAndDelete(aText,nil,{nodelete=}true) else
result := FindRawUTF8(pointer(fValue),aText,fCount,fCaseSensitive in fFlags);
if result>=0 then
InternalDelete(result);
finally
fSafe.UnLock;
end;
end;
function TRawUTF8List.DeleteFromName(const Name: RawUTF8): PtrInt;
begin
fSafe.Lock;
try
result := IndexOfName(Name);
Delete(result);
finally
fSafe.UnLock;
end;
end;
function TRawUTF8List.IndexOf(const aText: RawUTF8): PtrInt;
begin
if self<>nil then begin
fSafe.Lock;
try
if fNoDuplicate in fFlags then
result := fValues.FindHashed(aText) else
result := FindRawUTF8(pointer(fValue),aText,fCount,fCaseSensitive in fFlags);
finally
fSafe.UnLock;
end;
end else
result := -1;
end;
function TRawUTF8List.Get(Index: PtrInt): RawUTF8;
begin
if (self=nil) or (PtrUInt(Index)>=PtrUInt(fCount)) then
result := '' else
result := fValue[Index];
end;
function TRawUTF8List.GetCapacity: PtrInt;
begin
if self=nil then
result := 0 else
result := length(fValue);
end;
function TRawUTF8List.GetCount: PtrInt;
begin
if self=nil then
result := 0 else
result := fCount;
end;
function TRawUTF8List.GetTextPtr: PPUtf8CharArray;
begin
if self=nil then
result := nil else
result := pointer(fValue);
end;
function TRawUTF8List.GetObjectPtr: PPointerArray;
begin
if self=nil then
result := nil else
result := pointer(fObjects);
end;
function TRawUTF8List.GetName(Index: PtrInt): RawUTF8;
begin
result := Get(Index);
if result='' then
exit;
Index := PosExChar(NameValueSep,result);
if Index=0 then
result := '' else
SetLength(result,Index-1);
end;
function TRawUTF8List.GetObject(Index: PtrInt): pointer;
begin
if (self<>nil) and (fObjects<>nil) and (PtrUInt(Index)<PtrUInt(fCount)) then
result := fObjects[Index] else
result := nil;
end;
function TRawUTF8List.GetObjectFrom(const aText: RawUTF8): pointer;
var ndx: PtrUInt;
begin
result := nil;
if (self<>nil) and (fObjects<>nil) then begin
fSafe.Lock;
try
ndx := IndexOf(aText);
if ndx<PtrUInt(fCount) then
result := fObjects[ndx];
finally
fSafe.UnLock;
end;
end;
end;
function TRawUTF8List.GetText(const Delimiter: RawUTF8): RawUTF8;
var DelimLen, i, Len: PtrInt;
P: PUTF8Char;
begin
result := '';
if (self=nil) or (fCount=0) then
exit;
fSafe.Lock;
try
DelimLen := length(Delimiter);
Len := DelimLen*(fCount-1);
for i := 0 to fCount-1 do
inc(Len,length(fValue[i]));
FastSetString(result,nil,len);
P := pointer(result);
i := 0;
repeat
Len := length(fValue[i]);
if Len>0 then begin
MoveFast(pointer(fValue[i])^,P^,Len);
inc(P,Len);
end;
inc(i);
if i>=fCount then
Break;
if DelimLen>0 then begin
MoveSmall(pointer(Delimiter),P,DelimLen);
inc(P,DelimLen);
end;
until false;
finally
fSafe.UnLock;
end;
end;
procedure TRawUTF8List.SaveToStream(Dest: TStream; const Delimiter: RawUTF8);
var W: TTextWriter;
i: PtrInt;
temp: TTextWriterStackBuffer;
begin
if (self=nil) or (fCount=0) then
exit;
fSafe.Lock;
try
W := TTextWriter.Create(Dest,@temp,SizeOf(temp));
try
i := 0;
repeat
W.AddString(fValue[i]);
inc(i);
if i>=fCount then
Break;
W.AddString(Delimiter);
until false;
W.FlushFinal;
finally
W.Free;
end;
finally
fSafe.UnLock;
end;
end;
procedure TRawUTF8List.SaveToFile(const FileName: TFileName; const Delimiter: RawUTF8);
var FS: TFileStream;
begin
FS := TFileStream.Create(FileName,fmCreate);
try
SaveToStream(FS,Delimiter);
finally
FS.Free;
end;
end;
function TRawUTF8List.GetTextCRLF: RawUTF8;
begin
result := GetText;
end;
function TRawUTF8List.GetValue(const Name: RawUTF8): RawUTF8;
begin
fSafe.Lock;
try
result := GetValueAt(IndexOfName(Name));
finally
fSafe.UnLock;
end;
end;
function TRawUTF8List.GetValueAt(Index: PtrInt): RawUTF8;
begin
if (self=nil) or (PtrUInt(Index)>=PtrUInt(fCount)) then
result := '' else
result := Get(Index);
if result='' then
exit;
Index := PosExChar(NameValueSep,result);
if Index=0 then
result := '' else
result := copy(result,Index+1,maxInt);
end;
function TRawUTF8List.IndexOfName(const Name: RawUTF8): PtrInt;
var UpperName: array[byte] of AnsiChar;
begin
if self<>nil then begin
PWord(UpperCopy255(UpperName,Name))^ := ord(NameValueSep);
for result := 0 to fCount-1 do
if IdemPChar(Pointer(fValue[result]),UpperName) then
exit;
end;
result := -1;
end;
function TRawUTF8List.IndexOfObject(aObject: TObject): PtrInt;
begin
if (self<>nil) and (fObjects<>nil) then begin
fSafe.Lock;
try
result := PtrUIntScanIndex(pointer(fObjects),fCount,PtrUInt(aObject));
finally
fSafe.UnLock;
end
end else
result := -1;
end;
function TRawUTF8List.Contains(const aText: RawUTF8; aFirstIndex: integer): PtrInt;
var i: PtrInt; // use a temp variable to make oldest Delphi happy :(
begin
result := -1;
if self<>nil then begin
fSafe.Lock;
try
for i := aFirstIndex to fCount-1 do
if PosEx(aText,fValue[i])>0 then begin
result := i;
exit;
end;
finally
fSafe.UnLock;
end;
end;
end;
procedure TRawUTF8List.OnChangeHidden(Sender: TObject);
begin
if self<>nil then
include(fFlags,fOnChangeTrigerred);
end;
procedure TRawUTF8List.Put(Index: PtrInt; const Value: RawUTF8);
begin
if (self<>nil) and (PtrUInt(Index)<PtrUInt(fCount)) then begin
fValue[Index] := Value;
if Assigned(fOnChange) then
Changed;
end;
end;
procedure TRawUTF8List.PutObject(Index: PtrInt; Value: pointer);
begin
if (self<>nil) and (PtrUInt(Index)<PtrUInt(fCount)) then begin
if fObjects=nil then
SetLength(fObjects,Length(fValue));
fObjects[Index] := Value;
if Assigned(fOnChange) then
Changed;
end;
end;
procedure TRawUTF8List.SetText(const aText: RawUTF8; const Delimiter: RawUTF8);
begin
SetTextPtr(pointer(aText),PUTF8Char(pointer(aText))+length(aText),Delimiter);
end;
procedure TRawUTF8List.LoadFromFile(const FileName: TFileName);
var Map: TMemoryMap;
P: PUTF8Char;
begin
if Map.Map(FileName) then
try
if Map.Size<>0 then begin
if TextFileKind(Map)=isUTF8 then begin // ignore UTF-8 BOM
P := pointer(Map.Buffer+3);
SetTextPtr(P,P+Map.Size-3,#13#10);
end else begin
P := pointer(Map.Buffer);
SetTextPtr(P,P+Map.Size,#13#10);
end;
end;
finally
Map.UnMap;
end;
end;
procedure TRawUTF8List.SetTextPtr(P,PEnd: PUTF8Char; const Delimiter: RawUTF8);
var DelimLen: PtrInt;
DelimFirst: AnsiChar;
PBeg, DelimNext: PUTF8Char;
Line: RawUTF8;
begin
DelimLen := length(Delimiter);
BeginUpdate; // also makes fSafe.Lock
try
Clear;
if (P<>nil) and (DelimLen>0) and (P<PEnd) then begin
DelimFirst := Delimiter[1];
DelimNext := PUTF8Char(pointer(Delimiter))+1;
repeat
PBeg := P;
while P<PEnd do begin
if (P^=DelimFirst) and CompareMemSmall(P+1,DelimNext,DelimLen-1) then
break;
inc(P);
end;
FastSetString(Line,PBeg,P-PBeg);
AddObject(Line,nil);
if P>=PEnd then
break;
inc(P,DelimLen);
until P>=PEnd;
end;
finally
EndUpdate;
end;
end;
procedure TRawUTF8List.SetTextCRLF(const Value: RawUTF8);
begin
SetText(Value,#13#10);
end;
procedure TRawUTF8List.SetFrom(const aText: TRawUTF8DynArray; const aObject: TObjectDynArray);
var n: integer;
begin
BeginUpdate; // also makes fSafe.Lock
try
Clear;
n := length(aText);
if n=0 then
exit;
SetCapacity(n);
fCount := n;
fValue := aText;
fObjects := aObject;
if fNoDuplicate in fFlags then
fValues.ReHash;
finally
EndUpdate;
end;
end;
procedure TRawUTF8List.SetValue(const Name, Value: RawUTF8);
var i: PtrInt;
txt: RawUTF8;
begin
txt := Name+RawUTF8(NameValueSep)+Value;
fSafe.Lock;
try
i := IndexOfName(Name);
if i<0 then
AddObject(txt,nil) else
if fValue[i]<>txt then begin
fValue[i] := txt;
if fNoDuplicate in fFlags then
fValues.Hasher.Clear; // invalidate internal hash table
Changed;
end;
finally
fSafe.UnLock;
end;
end;
function TRawUTF8List.GetCaseSensitive: boolean;
begin
result := (self<>nil) and (fCaseSensitive in fFlags);
end;
function TRawUTF8List.GetNoDuplicate: boolean;
begin
result := (self<>nil) and (fNoDuplicate in fFlags);
end;
function TRawUTF8List.UpdateValue(const Name: RawUTF8; var Value: RawUTF8;
ThenDelete: boolean): boolean;
var i: PtrInt;
begin
result := false;
fSafe.Lock;
try
i := IndexOfName(Name);
if i>=0 then begin
Value := GetValueAt(i); // copy value
if ThenDelete then
Delete(i); // optionally delete
result := true;
end;
finally
fSafe.UnLock;
end;
end;
function TRawUTF8List.PopFirst(out aText: RawUTF8; aObject: PObject): boolean;
begin
result := false;
if fCount=0 then
exit;
fSafe.Lock;
try
if fCount>0 then begin
aText := fValue[0];
if aObject<>nil then
if fObjects<>nil then
aObject^ := fObjects[0] else
aObject^ := nil;
Delete(0);
result := true;
end;
finally
fSafe.UnLock;
end;
end;
function TRawUTF8List.PopLast(out aText: RawUTF8; aObject: PObject): boolean;
var last: PtrInt;
begin
result := false;
if fCount=0 then
exit;
fSafe.Lock;
try
last := fCount-1;
if last>=0 then begin
aText := fValue[last];
if aObject<>nil then
if fObjects<>nil then
aObject^ := fObjects[last] else
aObject^ := nil;
Delete(last);
result := true;
end;
finally
fSafe.UnLock;
end;
end;
{ TObjectListHashedAbstract}
constructor TObjectListHashedAbstract.Create(aFreeItems: boolean);
begin
inherited Create;
fHash.Init(TypeInfo(TObjectDynArray),fList,@HashPtrUInt,@SortDynArrayPointer,nil,@fCount);
fHash.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}SetIsObjArray(aFreeItems);
end;
destructor TObjectListHashedAbstract.Destroy;
begin
fHash.Clear; // will free items if needed
inherited;
end;
procedure TObjectListHashedAbstract.Delete(aIndex: integer);
begin
if (self<>nil) and
fHash.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}Delete(aIndex) then
fHash.fHash.Clear;
end;
procedure TObjectListHashedAbstract.Delete(aObject: TObject);
begin
Delete(IndexOf(aObject));
end;
{ TObjectListHashed }
function TObjectListHashed.Add(aObject: TObject; out wasAdded: boolean): integer;
begin
wasAdded := false;
if self<>nil then begin
result := fHash.FindHashedForAdding(aObject,wasAdded);
if wasAdded then
fList[result] := aObject;
end else
result := -1;
end;
function TObjectListHashed.IndexOf(aObject: TObject): integer;
begin
if (self<>nil) and (fCount>0) then
result := fHash.FindHashed(aObject) else
result := -1;
end;
procedure TObjectListHashed.Delete(aObject: TObject);
begin
fHash.FindHashedAndDelete(aObject);
end;
{ TObjectListPropertyHashed }
constructor TObjectListPropertyHashed.Create(
aSubPropAccess: TObjectListPropertyHashedAccessProp;
aHashElement: TDynArrayHashOne; aCompare: TDynArraySortCompare;
aFreeItems: boolean);
begin
inherited Create(aFreeItems);
fSubPropAccess := aSubPropAccess;
if Assigned(aHashElement) then
fHash.fHash.HashElement := aHashElement;
if Assigned(aCompare) then
fHash.fHash.Compare := aCompare;
fHash.EventCompare := IntComp;
fHash.EventHash := IntHash;
end;
function TObjectListPropertyHashed.IntHash(const Elem): cardinal;
var O: TObject;
begin
O := fSubPropAccess(TObject(Elem));
result := fHash.fHash.HashElement(O,fHash.fHash.Hasher);
end;
function TObjectListPropertyHashed.IntComp(const A,B): integer;
var O: TObject;
begin
O := fSubPropAccess(TObject(A));
result := fHash.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare(O,B);
end;
function TObjectListPropertyHashed.Add(aObject: TObject; out wasAdded: boolean): integer;
begin
wasAdded := false;
if self<>nil then begin
result := fHash.FindHashedForAdding(aObject,wasAdded,
fHash.fHash.HashElement(aObject,fHash.fHash.Hasher));
if wasAdded then
fList[result] := aObject;
end else
result := -1;
end;
function TObjectListPropertyHashed.IndexOf(aObject: TObject): integer;
var h: cardinal;
begin
if fCount>0 then begin
h := fHash.fHash.HashElement(aObject,fHash.fHash.Hasher);
result := fHash.fHash.FindOrNew(h,@aObject); // fallback to Scan() if needed
if result>=0 then
exit else // found
result := -1; // for consistency
end else
result := -1;
end;
{ TPointerClassHashed }
constructor TPointerClassHashed.Create(aInfo: pointer);
begin
fInfo := aInfo;
end;
{ TPointerClassHash }
function PointerClassHashProcess(aObject: TPointerClassHashed): pointer;
begin
if aObject=nil then // may happen for Rehash after SetCount(n+1)
result := nil else
result := aObject.Info;
end;
constructor TPointerClassHash.Create;
begin
inherited Create(@PointerClassHashProcess);
end;
function TPointerClassHash.TryAdd(aInfo: pointer): PPointerClassHashed;
var wasAdded: boolean;
i: integer;
begin
i := inherited Add(aInfo,wasAdded);
if wasAdded then
result := @List[i] else
result := nil;
end;
function TPointerClassHash.Find(aInfo: pointer): TPointerClassHashed;
var i: integer;
p: ^TPointerClassHashed;
begin
if self<>nil then begin
if fCount<64 then begin // brute force is faster for small count
p := pointer(List);
for i := 1 to fCount do begin
result := p^;
if result.fInfo=aInfo then
exit;
inc(p);
end;
end else begin
i := IndexOf(aInfo); // use hashing
if i>=0 then begin
result := TPointerClassHashed(List[i]);
exit;
end;
end;
end;
result := nil;
end;
{ TPointerClassHashLocked }
constructor TPointerClassHashLocked.Create;
begin
inherited Create;
fSafe.Init;
end;
destructor TPointerClassHashLocked.Destroy;
begin
fSafe.Done;
inherited Destroy;
end;
function TPointerClassHashLocked.FindLocked(aInfo: pointer): TPointerClassHashed;
begin
if self=nil then
result := nil else begin
fSafe.Lock;
try
result := inherited Find(aInfo);
finally
fSafe.UnLock;
end;
end;
end;
function TPointerClassHashLocked.TryAddLocked(aInfo: pointer;
out aNewEntry: PPointerClassHashed): boolean;
var wasAdded: boolean;
i: integer;
begin
fSafe.Lock;
i := inherited Add(aInfo,wasAdded);
if wasAdded then begin
aNewEntry := @List[i];
result := true; // caller should call Unlock
end else begin
fSafe.UnLock;
result := false;
end;
end;
procedure TPointerClassHashLocked.Unlock;
begin
fSafe.UnLock;
end;
{ TSynDictionary }
const
DIC_KEYCOUNT = 0;
DIC_KEY = 1;
DIC_VALUECOUNT = 2;
DIC_VALUE = 3;
DIC_TIMECOUNT = 4;
DIC_TIMESEC = 5;
DIC_TIMETIX = 6;
function TSynDictionary.KeyFullHash(const Elem): cardinal;
begin
result := fKeys.fHash.Hasher(0,@Elem,fKeys.ElemSize);
end;
function TSynDictionary.KeyFullCompare(const A,B): integer;
var i: PtrInt;
begin
for i := 0 to fKeys.ElemSize-1 do begin
result := TByteArray(A)[i]-TByteArray(B)[i];
if result<>0 then
exit;
end;
result := 0;
end;
constructor TSynDictionary.Create(aKeyTypeInfo,aValueTypeInfo: pointer;
aKeyCaseInsensitive: boolean; aTimeoutSeconds: cardinal; aCompressAlgo: TAlgoCompress);
begin
inherited Create;
fSafe.Padding[DIC_KEYCOUNT].VType := varInteger;
fSafe.Padding[DIC_KEY].VType := varUnknown;
fSafe.Padding[DIC_VALUECOUNT].VType := varInteger;
fSafe.Padding[DIC_VALUE].VType := varUnknown;
fSafe.Padding[DIC_TIMECOUNT].VType := varInteger;
fSafe.Padding[DIC_TIMESEC].VType := varInteger;
fSafe.Padding[DIC_TIMETIX].VType := varInteger;
fSafe.PaddingUsedCount := DIC_TIMETIX+1;
fKeys.Init(aKeyTypeInfo,fSafe.Padding[DIC_KEY].VAny,nil,nil,nil,
@fSafe.Padding[DIC_KEYCOUNT].VInteger,aKeyCaseInsensitive);
if not Assigned(fKeys.HashElement) then
fKeys.EventHash := KeyFullHash;
if not Assigned(fKeys.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare) then
fKeys.EventCompare := KeyFullCompare;
fValues.Init(aValueTypeInfo,fSafe.Padding[DIC_VALUE].VAny,
@fSafe.Padding[DIC_VALUECOUNT].VInteger);
fTimeouts.Init(TypeInfo(TIntegerDynArray),fTimeOut,@fSafe.Padding[DIC_TIMECOUNT].VInteger);
if aCompressAlgo=nil then
aCompressAlgo := AlgoSynLZ;
fCompressAlgo := aCompressAlgo;
fSafe.Padding[DIC_TIMESEC].VInteger := aTimeoutSeconds;
end;
function TSynDictionary.ComputeNextTimeOut: cardinal;
begin
result := fSafe.Padding[DIC_TIMESEC].VInteger;
if result<>0 then
result := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+result;
end;
function TSynDictionary.GetCapacity: integer;
begin
fSafe.Lock;
result := fKeys.GetCapacity;
fSafe.UnLock;
end;
procedure TSynDictionary.SetCapacity(const Value: integer);
begin
fSafe.Lock;
fKeys.Capacity := Value;
fValues.Capacity := Value;
if fSafe.Padding[DIC_TIMESEC].VInteger>0 then
fTimeOuts.Capacity := Value;
fSafe.UnLock;
end;
function TSynDictionary.GetTimeOutSeconds: cardinal;
begin
result := fSafe.Padding[DIC_TIMESEC].VInteger;
end;
procedure TSynDictionary.SetTimeouts;
var i: PtrInt;
timeout: cardinal;
begin
if fSafe.Padding[DIC_TIMESEC].VInteger=0 then
exit;
fTimeOuts.SetCount(fSafe.Padding[DIC_KEYCOUNT].VInteger);
timeout := ComputeNextTimeOut;
for i := 0 to fSafe.Padding[DIC_TIMECOUNT].VInteger-1 do
fTimeOut[i] := timeout;
end;
function TSynDictionary.DeleteDeprecated: integer;
var i: PtrInt;
now: cardinal;
begin
result := 0;
if (self=nil) or (fSafe.Padding[DIC_TIMECOUNT].VInteger=0) or // no entry
(fSafe.Padding[DIC_TIMESEC].VInteger=0) then // nothing in fTimeOut[]
exit;
now := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10;
if fSafe.Padding[DIC_TIMETIX].VInteger=integer(now) then
exit; // no need to search more often than every second
fSafe.Lock;
try
fSafe.Padding[DIC_TIMETIX].VInteger := now;
for i := fSafe.Padding[DIC_TIMECOUNT].VInteger-1 downto 0 do
if (now>fTimeOut[i]) and (fTimeOut[i]<>0) and
(not Assigned(fOnCanDelete) or
fOnCanDelete(fKeys.ElemPtr(i)^,fValues.ElemPtr(i)^,i)) then begin
fKeys.Delete(i);
fValues.Delete(i);
fTimeOuts.Delete(i);
inc(result);
end;
if result>0 then
fKeys.Rehash; // mandatory after fKeys.Delete(i)
finally
fSafe.UnLock;
end;
end;
procedure TSynDictionary.DeleteAll;
begin
if self=nil then
exit;
fSafe.Lock;
try
fKeys.Clear;
fKeys.Hasher.Clear; // mandatory to avoid GPF
fValues.Clear;
if fSafe.Padding[DIC_TIMESEC].VInteger>0 then
fTimeOuts.Clear;
finally
fSafe.UnLock;
end;
end;
destructor TSynDictionary.Destroy;
begin
fKeys.Clear;
fValues.Clear;
inherited Destroy;
end;
function TSynDictionary.Add(const aKey, aValue): integer;
var added: boolean;
tim: cardinal;
begin
fSafe.Lock;
try
result := fKeys.FindHashedForAdding(aKey,added);
if added then begin
with fKeys{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do
ElemCopyFrom(aKey,result); // fKey[result] := aKey;
if fValues.Add(aValue)<>result then
raise ESynException.CreateUTF8('%.Add fValues.Add',[self]);
tim := ComputeNextTimeOut;
if tim>0 then
fTimeOuts.Add(tim);
end else
result := -1;
finally
fSafe.UnLock;
end;
end;
function TSynDictionary.AddOrUpdate(const aKey, aValue): integer;
var added: boolean;
tim: cardinal;
begin
fSafe.Lock;
try
tim := ComputeNextTimeOut;
result := fKeys.FindHashedForAdding(aKey,added);
if added then begin
with fKeys{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do
ElemCopyFrom(aKey,result); // fKey[result] := aKey
if fValues.Add(aValue)<>result then
raise ESynException.CreateUTF8('%.AddOrUpdate fValues.Add',[self]);
if tim<>0 then
fTimeOuts.Add(tim);
end else begin
fValues.ElemCopyFrom(aValue,result,{ClearBeforeCopy=}true);
if tim<>0 then
fTimeOut[result] := tim;
end;
finally
fSafe.UnLock;
end;
end;
function TSynDictionary.Clear(const aKey): integer;
begin
fSafe.Lock;
try
result := fKeys.FindHashed(aKey);
if result>=0 then begin
fValues.ElemClear(fValues.ElemPtr(result)^);
if fSafe.Padding[DIC_TIMESEC].VInteger>0 then
fTimeOut[result] := 0;
end;
finally
fSafe.UnLock;
end;
end;
function TSynDictionary.Delete(const aKey): integer;
begin
fSafe.Lock;
try
result := fKeys.FindHashedAndDelete(aKey);
if result>=0 then begin
fValues.Delete(result);
if fSafe.Padding[DIC_TIMESEC].VInteger>0 then
fTimeOuts.Delete(result);
end;
finally
fSafe.UnLock;
end;
end;
function TSynDictionary.DeleteAt(aIndex: integer): boolean;
begin
if cardinal(aIndex)<cardinal(fSafe.Padding[DIC_KEYCOUNT].VInteger) then
// use Delete(aKey) to have efficient hash table update
result := Delete(fKeys.ElemPtr(aIndex)^)=aIndex else
result := false;
end;
function TSynDictionary.InArray(const aKey, aArrayValue;
aAction: TSynDictionaryInArray): boolean;
var nested: TDynArray;
ndx: integer;
begin
result := false;
if (fValues.ElemType=nil) or (PTypeKind(fValues.ElemType)^<>tkDynArray) then
raise ESynException.CreateUTF8('%.Values: % items are not dynamic arrays',
[self,fValues.ArrayTypeShort^]);
fSafe.Lock;
try
ndx := fKeys.FindHashed(aKey);
if ndx<0 then
exit;
nested.Init(fValues.ElemType,fValues.ElemPtr(ndx)^);
case aAction of
iaFind:
result := nested.Find(aArrayValue)>=0;
iaFindAndDelete:
result := nested.FindAndDelete(aArrayValue)>=0;
iaFindAndUpdate:
result := nested.FindAndUpdate(aArrayValue)>=0;
iaFindAndAddIfNotExisting:
result := nested.FindAndAddIfNotExisting(aArrayValue)>=0;
iaAdd:
result := nested.Add(aArrayValue)>=0;
end;
finally
fSafe.UnLock;
end;
end;
function TSynDictionary.FindInArray(const aKey, aArrayValue): boolean;
begin
result := InArray(aKey,aArrayValue,iaFind);
end;
function TSynDictionary.FindKeyFromValue(const aValue; out aKey;
aUpdateTimeOut: boolean): boolean;
var ndx: integer;
begin
fSafe.Lock;
try
ndx := fValues.IndexOf(aValue);
result := ndx>=0;
if result then begin
fKeys.ElemCopyAt(ndx,aKey);
if aUpdateTimeOut then
SetTimeoutAtIndex(ndx);
end;
finally
fSafe.UnLock;
end;
end;
function TSynDictionary.DeleteInArray(const aKey, aArrayValue): boolean;
begin
result := InArray(aKey,aArrayValue,iaFindAndDelete);
end;
function TSynDictionary.UpdateInArray(const aKey, aArrayValue): boolean;
begin
result := InArray(aKey,aArrayValue,iaFindAndUpdate);
end;
function TSynDictionary.AddInArray(const aKey, aArrayValue): boolean;
begin
result := InArray(aKey,aArrayValue,iaAdd);
end;
function TSynDictionary.AddOnceInArray(const aKey, aArrayValue): boolean;
begin
result := InArray(aKey,aArrayValue,iaFindAndAddIfNotExisting);
end;
function TSynDictionary.Find(const aKey; aUpdateTimeOut: boolean): integer;
var tim: cardinal;
begin // caller is expected to call fSafe.Lock/Unlock
if self=nil then
result := -1 else
result := fKeys.FindHashed(aKey);
if aUpdateTimeOut and (result>=0) then begin
tim := fSafe.Padding[DIC_TIMESEC].VInteger;
if tim>0 then // inlined fTimeout[result] := GetTimeout
fTimeout[result] := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+tim;
end;
end;
function TSynDictionary.FindValue(const aKey; aUpdateTimeOut: boolean; aIndex: PInteger): pointer;
var ndx: PtrInt;
begin
ndx := Find(aKey,aUpdateTimeOut);
if aIndex<>nil then
aIndex^ := ndx;
if ndx<0 then
result := nil else
result := pointer(PtrUInt(fValues.fValue^)+PtrUInt(ndx)*fValues.ElemSize);
end;
function TSynDictionary.FindValueOrAdd(const aKey; var added: boolean;
aIndex: PInteger): pointer;
var ndx: integer;
tim: cardinal;
begin
tim := fSafe.Padding[DIC_TIMESEC].VInteger; // inlined tim := GetTimeout
if tim<>0 then
tim := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+tim;
ndx := fKeys.FindHashedForAdding(aKey,added);
if added then begin
with fKeys{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do
ElemCopyFrom(aKey,ndx); // fKey[i] := aKey
fValues.SetCount(ndx+1); // reserve new place for associated value
if tim>0 then
fTimeOuts.Add(tim);
end else
if tim>0 then
fTimeOut[ndx] := tim;
if aIndex<>nil then
aIndex^ := ndx;
result := fValues.ElemPtr(ndx);
end;
function TSynDictionary.FindAndCopy(const aKey; out aValue; aUpdateTimeOut: boolean): boolean;
var ndx: integer;
begin
fSafe.Lock;
try
ndx := Find(aKey, aUpdateTimeOut);
if ndx>=0 then begin
fValues.ElemCopyAt(ndx,aValue);
result := true;
end else
result := false;
finally
fSafe.UnLock;
end;
end;
function TSynDictionary.FindAndExtract(const aKey; out aValue): boolean;
var ndx: integer;
begin
fSafe.Lock;
try
ndx := fKeys.FindHashedAndDelete(aKey);
if ndx>=0 then begin
fValues.ElemCopyAt(ndx,aValue);
fValues.Delete(ndx);
if fSafe.Padding[DIC_TIMESEC].VInteger>0 then
fTimeOuts.Delete(ndx);
result := true;
end else
result := false;
finally
fSafe.UnLock;
end;
end;
function TSynDictionary.Exists(const aKey): boolean;
begin
fSafe.Lock;
try
result := fKeys.FindHashed(aKey)>=0;
finally
fSafe.UnLock;
end;
end;
{$ifndef DELPHI5OROLDER}
procedure TSynDictionary.CopyValues(out Dest; ObjArrayByRef: boolean);
begin
fSafe.Lock;
try
fValues.CopyTo(Dest,ObjArrayByRef);
finally
fSafe.UnLock;
end;
end;
{$endif DELPHI5OROLDER}
function TSynDictionary.ForEach(const OnEach: TSynDictionaryEvent; Opaque: pointer): integer;
var k,v: PAnsiChar;
i,n,ks,vs: integer;
begin
result := 0;
fSafe.Lock;
try
n := fSafe.Padding[DIC_KEYCOUNT].VInteger;
if (n=0) or not Assigned(OnEach) then
exit;
k := fKeys.Value^;
ks := fKeys.ElemSize;
v := fValues.Value^;
vs := fValues.ElemSize;
for i := 0 to n-1 do begin
inc(result);
if not OnEach(k^,v^,i,n,Opaque) then
break;
inc(k,ks);
inc(v,vs);
end;
finally
fSafe.UnLock;
end;
end;
function TSynDictionary.ForEach(const OnMatch: TSynDictionaryEvent;
KeyCompare,ValueCompare: TDynArraySortCompare; const aKey,aValue;
Opaque: pointer): integer;
var k,v: PAnsiChar;
i,n,ks,vs: integer;
begin
fSafe.Lock;
try
result := 0;
if not Assigned(OnMatch) or
(not Assigned(KeyCompare) and not Assigned(ValueCompare)) then
exit;
n := fSafe.Padding[DIC_KEYCOUNT].VInteger;
k := fKeys.Value^;
ks := fKeys.ElemSize;
v := fValues.Value^;
vs := fValues.ElemSize;
for i := 0 to n-1 do begin
if (Assigned(KeyCompare) and (KeyCompare(k^,aKey)=0)) or
(Assigned(ValueCompare) and (ValueCompare(v^,aValue)=0)) then begin
inc(result);
if not OnMatch(k^,v^,i,n,Opaque) then
break;
end;
inc(k,ks);
inc(v,vs);
end;
finally
fSafe.UnLock;
end;
end;
procedure TSynDictionary.SetTimeoutAtIndex(aIndex: integer);
var tim: cardinal;
begin
if cardinal(aIndex) >= cardinal(fSafe.Padding[DIC_KEYCOUNT].VInteger) then
exit;
tim := fSafe.Padding[DIC_TIMESEC].VInteger;
if tim > 0 then
fTimeOut[aIndex] := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+tim;
end;
function TSynDictionary.Count: integer;
begin
{$ifdef NOVARIANTS}
result := RawCount;
{$else}
result := fSafe.LockedInt64[DIC_KEYCOUNT];
{$endif}
end;
function TSynDictionary.RawCount: integer;
begin
result := fSafe.Padding[DIC_KEYCOUNT].VInteger;
end;
procedure TSynDictionary.SaveToJSON(W: TTextWriter; EnumSetsAsText: boolean);
var k,v: RawUTF8;
begin
fSafe.Lock;
try
fKeys.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}SaveToJSON(k,EnumSetsAsText);
fValues.SaveToJSON(v,EnumSetsAsText);
finally
fSafe.UnLock;
end;
W.AddJSONArraysAsJSONObject(pointer(k),pointer(v));
end;
function TSynDictionary.SaveToJSON(EnumSetsAsText: boolean): RawUTF8;
var W: TTextWriter;
temp: TTextWriterStackBuffer;
begin
W := DefaultTextWriterSerializer.CreateOwnedStream(temp);
try
SaveToJSON(W,EnumSetsAsText);
W.SetText(result);
finally
W.Free;
end;
end;
function TSynDictionary.SaveValuesToJSON(EnumSetsAsText: boolean): RawUTF8;
begin
fSafe.Lock;
try
fValues.SaveToJSON(result,EnumSetsAsText);
finally
fSafe.UnLock;
end;
end;
function TSynDictionary.LoadFromJSON(const JSON: RawUTF8
{$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): boolean;
begin // pointer(JSON) is not modified in-place thanks to JSONObjectAsJSONArrays()
result := LoadFromJSON(pointer(JSON){$ifndef NOVARIANTS},CustomVariantOptions{$endif});
end;
function TSynDictionary.LoadFromJSON(JSON: PUTF8Char{$ifndef NOVARIANTS};
CustomVariantOptions: PDocVariantOptions{$endif}): boolean;
var k,v: RawUTF8; // private copy of the JSON input, expanded as Keys/Values arrays
begin
result := false;
if not JSONObjectAsJSONArrays(JSON,k,v) then
exit;
fSafe.Lock;
try
if fKeys.LoadFromJSON(pointer(k),nil{$ifndef NOVARIANTS},CustomVariantOptions{$endif})<>nil then
if fValues.LoadFromJSON(pointer(v),nil{$ifndef NOVARIANTS},CustomVariantOptions{$endif})<>nil then
if fKeys.Count=fValues.Count then begin
SetTimeouts;
fKeys.Rehash; // warning: duplicated keys won't be identified
result := true;
end;
finally
fSafe.UnLock;
end;
end;
function TSynDictionary.LoadFromBinary(const binary: RawByteString): boolean;
var plain: RawByteString;
P,PEnd: PAnsiChar;
begin
result := false;
plain := fCompressAlgo.Decompress(binary);
P := pointer(plain);
if P=nil then
exit;
PEnd := P+length(plain);
fSafe.Lock;
try
P := fKeys.LoadFrom(P,nil,{checkhash=}false,PEnd);
if P<>nil then
P := fValues.LoadFrom(P,nil,{checkhash=}false,PEnd);
if (P<>nil) and (fKeys.Count=fValues.Count) then begin
SetTimeouts; // set ComputeNextTimeOut for all items
fKeys.ReHash; // optimistic: input from safe TSynDictionary.SaveToBinary
result := true;
end;
finally
fSafe.UnLock;
end;
end;
class function TSynDictionary.OnCanDeleteSynPersistentLock(const aKey, aValue;
aIndex: integer): boolean;
begin
result := not TSynPersistentLock(aValue).Safe^.IsLocked;
end;
class function TSynDictionary.OnCanDeleteSynPersistentLocked(const aKey, aValue;
aIndex: integer): boolean;
begin
result := not TSynPersistentLock(aValue).Safe.IsLocked;
end;
function TSynDictionary.SaveToBinary(NoCompression: boolean): RawByteString;
var tmp: TSynTempBuffer;
trigger: integer;
begin
fSafe.Lock;
try
result := '';
if fSafe.Padding[DIC_KEYCOUNT].VInteger = 0 then
exit;
tmp.Init(fKeys.SaveToLength+fValues.SaveToLength);
if fValues.SaveTo(fKeys.SaveTo(tmp.buf))-PAnsiChar(tmp.buf)=tmp.len then begin
if NoCompression then
trigger := maxInt else
trigger := 128;
result := fCompressAlgo.Compress(tmp.buf,tmp.len,trigger);
end;
tmp.Done;
finally
fSafe.UnLock;
end;
end;
{ TMemoryMap }
function TMemoryMap.Map(aFile: THandle; aCustomSize: PtrUInt; aCustomOffset: Int64): boolean;
var Available: Int64;
begin
fBuf := nil;
fBufSize := 0;
{$ifdef MSWINDOWS}
fMap := 0;
{$endif}
fFileLocal := false;
fFile := aFile;
fFileSize := FileSeek64(fFile,0,soFromEnd);
if fFileSize=0 then begin
result := true; // handle 0 byte file without error (but no memory map)
exit;
end;
result := false;
if (fFileSize<=0) {$ifdef CPU32}or (fFileSize>maxInt){$endif} then
/// maxInt = $7FFFFFFF = 1.999 GB (2GB would induce PtrInt errors)
exit;
if aCustomSize=0 then
fBufSize := fFileSize else begin
Available := fFileSize-aCustomOffset;
if Available<0 then
exit;
if aCustomSize>Available then
fBufSize := Available;
fBufSize := aCustomSize;
end;
{$ifdef MSWINDOWS}
with PInt64Rec(@fFileSize)^ do
fMap := CreateFileMapping(fFile,nil,PAGE_READONLY,Hi,Lo,nil);
if fMap=0 then
raise ESynException.Create('TMemoryMap.Map: CreateFileMapping()=0');
with PInt64Rec(@aCustomOffset)^ do
fBuf := MapViewOfFile(fMap,FILE_MAP_READ,Hi,Lo,fBufSize);
if fBuf=nil then begin
// Windows failed to find a contiguous VA space -> fall back on direct read
CloseHandle(fMap);
fMap := 0;
{$else}
if aCustomOffset<>0 then
if aCustomOffset and (SystemInfo.dwPageSize-1)<>0 then
raise ESynException.CreateUTF8('fpmmap(aCustomOffset=%) with SystemInfo.dwPageSize=%',
[aCustomOffset,SystemInfo.dwPageSize]) else
aCustomOffset := aCustomOffset div SystemInfo.dwPageSize;
fBuf := {$ifdef KYLIX3}mmap{$else}fpmmap{$endif}(
nil,fBufSize,PROT_READ,MAP_SHARED,fFile,aCustomOffset);
if fBuf=MAP_FAILED then begin
fBuf := nil;
{$endif}
end else
result := true;
end;
procedure TMemoryMap.Map(aBuffer: pointer; aBufferSize: PtrUInt);
begin
fBuf := aBuffer;
fFileSize := aBufferSize;
fBufSize := aBufferSize;
{$ifdef MSWINDOWS}
fMap := 0;
{$endif}
fFile := 0;
fFileLocal := false;
end;
function TMemoryMap.Map(const aFileName: TFileName): boolean;
var F: THandle;
begin
result := false;
// Memory-mapped file access does not go through the cache manager so
// using FileOpenSequentialRead() is pointless here
F := FileOpen(aFileName,fmOpenRead or fmShareDenyNone);
if PtrInt(F)<0 then
exit;
if Map(F) then
result := true else
FileClose(F);
fFileLocal := result;
end;
procedure TMemoryMap.UnMap;
begin
{$ifdef MSWINDOWS}
if fMap<>0 then begin
UnmapViewOfFile(fBuf);
CloseHandle(fMap);
fMap := 0;
end;
{$else}
if (fBuf<>nil) and (fBufSize>0) and (fFile<>0) then
{$ifdef KYLIX3}munmap{$else}fpmunmap{$endif}(fBuf,fBufSize);
{$endif}
fBuf := nil;
fBufSize := 0;
if fFile<>0 then begin
if fFileLocal then
FileClose(fFile);
fFile := 0;
end;
end;
{ TSynMemoryStream }
constructor TSynMemoryStream.Create(const aText: RawByteString);
begin
inherited Create;
SetPointer(pointer(aText),length(aText));
end;
constructor TSynMemoryStream.Create(Data: pointer; DataLen: PtrInt);
begin
inherited Create;
SetPointer(Data,DataLen);
end;
function TSynMemoryStream.Write(const Buffer; Count: Integer): Longint;
begin
{$ifdef FPC}
result := 0; // makes FPC compiler happy
{$endif}
raise EStreamError.CreateFmt('Unexpected %s.Write',[ClassNameShort(self)^]);
end;
{ TSynMemoryStreamMapped }
constructor TSynMemoryStreamMapped.Create(const aFileName: TFileName;
aCustomSize: PtrUInt; aCustomOffset: Int64);
begin
fFileName := aFileName;
// Memory-mapped file access does not go through the cache manager so
// using FileOpenSequentialRead() is pointless here
fFileStream := TFileStream.Create(aFileName,fmOpenRead or fmShareDenyNone);
Create(fFileStream.Handle,aCustomSize,aCustomOffset);
end;
constructor TSynMemoryStreamMapped.Create(aFile: THandle;
aCustomSize: PtrUInt; aCustomOffset: Int64);
begin
if not fMap.Map(aFile,aCustomSize,aCustomOffset) then
raise ESynException.CreateUTF8('%.Create(%) mapping error',[self,fFileName]);
inherited Create(fMap.fBuf,fMap.fBufSize);
end;
destructor TSynMemoryStreamMapped.Destroy;
begin
fMap.UnMap;
fFileStream.Free;
inherited;
end;
function FileSeek64(Handle: THandle; const Offset: Int64; Origin: DWORD): Int64;
{$ifdef MSWINDOWS}
var R64: packed record Lo, Hi: integer; end absolute Result;
begin
Result := Offset;
R64.Lo := integer(SetFilePointer(Handle,R64.Lo,@R64.Hi,Origin));
if (R64.Lo=-1) and (GetLastError<>0) then
R64.Hi := -1; // so result=-1
end;
{$else}
begin
{$ifdef FPC}
result := FPLSeek(Handle,Offset,Origin);
{$else}
{$ifdef KYLIX3}
result := LibC.lseek64(Handle,Offset,Origin);
{$else}
// warning: this won't handle file size > 2 GB :(
result := FileSeek(Handle,Offset,Origin);
{$endif}
{$endif}
end;
{$endif}
function PropNameValid(P: PUTF8Char): boolean;
var tab: PTextCharSet;
begin
result := false;
tab := @TEXT_CHARS;
if (P=nil) or not (tcIdentifierFirstChar in tab[P^]) then
exit; // first char must be alphabetical
repeat
inc(P); // following chars can be alphanumerical
if tcIdentifier in tab[P^] then
continue;
if P^=#0 then
break;
exit;
until false;
result := true;
end;
function PropNamesValid(const Values: array of RawUTF8): boolean;
var i,j: integer;
tab: PTextCharSet;
begin
result := false;
tab := @TEXT_CHARS;
for i := 0 to high(Values) do
for j := 1 to length(Values[i]) do
if not (tcIdentifier in tab[Values[i][j]]) then
exit;
result := true;
end;
function JsonPropNameValid(P: PUTF8Char): boolean;
var tab: PJsonCharSet;
begin
tab := @JSON_CHARS;
if (P<>nil) and (jcJsonIdentifierFirstChar in tab[P^]) then begin
repeat
inc(P);
until not(jcJsonIdentifier in tab[P^]);
result := P^ = #0;
end else
result := false;
end;
function StrCompL(P1,P2: PUTF8Char; L, Default: Integer): PtrInt;
var i: PtrInt;
begin
i := 0;
repeat
result := PtrInt(P1[i])-PtrInt(P2[i]);
if result=0 then begin
inc(i);
if 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;
tab: {$ifdef CPUX86NOTPIC}TNormTable absolute NormToUpperAnsi7{$else}PNormTable{$endif};
begin
i := 0;
{$ifndef CPUX86NOTPIC}tab := @NormToUpperAnsi7;{$endif} // faster on PIC and x86_64
repeat
if tab[P1[i]]=tab[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;
function IsRowID(FieldName: PUTF8Char): boolean;
{$ifdef CPU64}
var f: Int64;
begin
if FieldName<>nil then begin
f := PInt64(FieldName)^;
result := (f and $ffdfdf=(ord('I')+ord('D')shl 8)) or (f and $ffdfdfdfdfdf=
(ord('R')+ord('O')shl 8+ord('W')shl 16+ord('I')shl 24+Int64(ord('D')) shl 32))
end
{$else}
begin
if FieldName<>nil then
result := (PInteger(FieldName)^ and $ffdfdf=ord('I')+ord('D')shl 8) or
((PIntegerArray(FieldName)^[0] and $dfdfdfdf=
ord('R')+ord('O')shl 8+ord('W')shl 16+ord('I')shl 24) and
(PIntegerArray(FieldName)^[1] and $ffdf=ord('D')))
{$endif} else result := false;
end;
function IsRowID(FieldName: PUTF8Char; FieldLen: integer): boolean;
begin
case FieldLen of
2: result :=
PWord(FieldName)^ and $dfdf=ord('I')+ord('D')shl 8;
5: result :=
(PInteger(FieldName)^ and $dfdfdfdf=
ord('R')+ord('O')shl 8+ord('W')shl 16+ord('I')shl 24) and
(ord(FieldName[4]) and $df=ord('D'));
else result := false;
end;
end;
function IsRowIDShort(const FieldName: shortstring): boolean;
begin
result :=
(PInteger(@FieldName)^ and $DFDFFF=
2+ord('I')shl 8+ord('D')shl 16) or
((PIntegerArray(@FieldName)^[0] and $dfdfdfff=
5+ord('R')shl 8+ord('O')shl 16+ord('W')shl 24) and
(PIntegerArray(@FieldName)^[1] and $dfdf=
ord('I')+ord('D')shl 8));
end;
function GotoNextSqlIdentifier(P: PUtf8Char; tab: PTextCharSet): PUtf8Char;
{$ifdef HASINLINE} inline; {$endif}
begin
while tcCtrlNot0Comma in tab[P^] do inc(P); // in [#1..' ', ';']
if PWord(P)^=ord('/')+ord('*') shl 8 then begin // ignore e.g. '/*nocache*/'
repeat
inc(P);
if PWord(P)^ = ord('*')+ord('/') shl 8 then begin
inc(P, 2);
break;
end;
until P^ = #0;
while tcCtrlNot0Comma in tab[P^] do inc(P);
end;
result := P;
end;
function GetNextFieldProp(var P: PUTF8Char; var Prop: RawUTF8): boolean;
var B: PUTF8Char;
tab: PTextCharSet;
begin
tab := @TEXT_CHARS;
P := GotoNextSqlIdentifier(P, tab);
B := P;
while tcIdentifier in tab[P^] do inc(P); // go to end of field name
FastSetString(Prop,B,P-B);
P := GotoNextSqlIdentifier(P, tab);
result := Prop<>'';
end;
function GetNextFieldPropSameLine(var P: PUTF8Char; var Prop: ShortString): boolean;
var B: PUTF8Char;
tab: PTextCharSet;
begin
tab := @TEXT_CHARS;
while tcCtrlNotLF in tab[P^] do inc(P);
B := P;
while tcIdentifier in tab[P^] do inc(P); // go to end of field name
SetString(Prop,PAnsiChar(B),P-B);
while tcCtrlNotLF in TEXT_CHARS[P^] do inc(P);
result := Prop<>'';
end;
type
TSynLZHead = packed record
Magic: cardinal;
CompressedSize: integer;
HashCompressed: cardinal;
UnCompressedSize: integer;
HashUncompressed: cardinal;
end;
PSynLZHead = ^TSynLZHead;
TSynLZTrailer = packed record
HeaderRelativeOffset: cardinal;
Magic: cardinal;
end;
PSynLZTrailer = ^TSynLZTrailer;
function StreamSynLZComputeLen(P: PAnsiChar; Len, aMagic: cardinal): integer;
begin
if (P=nil) or (Len<=SizeOf(TSynLZTrailer)) then
result := 0 else
with PSynLZTrailer(P+Len-SizeOf(TSynLZTrailer))^ do
if (Magic=aMagic) and (HeaderRelativeOffset<Len) and
(PSynLZHead(P+Len-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.WriteBuffer(Head,SizeOf(Head));
Dest.WriteBuffer(D^,Head.CompressedSize);
Trailer.HeaderRelativeOffset := result+(SizeOf(Head)+SizeOf(Trailer));
Trailer.Magic := Magic;
Dest.WriteBuffer(Trailer,SizeOf(Trailer));
result := Head.CompressedSize+(SizeOf(Head)+SizeOf(Trailer));
finally
tmp.Done;
end;
end;
function StreamSynLZ(Source: TCustomMemoryStream; const DestFile: TFileName;
Magic: cardinal): integer;
var F: TFileStream;
begin
F := TFileStream.Create(DestFile,fmCreate);
try
result := StreamSynLZ(Source,F,Magic);
finally
F.Free;
end;
end;
function FileSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean;
var src,dst: RawByteString;
S,D: THandleStream;
Head: TSynLZHead;
Count,Max: Int64;
begin
result := false;
if FileExists(Source) then
try
S := FileStreamSequentialRead(Source);
try
DeleteFile(Dest);
Max := 128 shl 20; // 128 MB default compression chunk
D := TFileStream.Create(Dest,fmCreate);
try
Head.Magic := Magic;
Count := S.Size;
while Count>0 do begin
if Count>Max then
Head.UnCompressedSize := Max else
Head.UnCompressedSize := Count;
if src='' then
SetString(src,nil,Head.UnCompressedSize);
if dst='' then
SetString(dst,nil,SynLZcompressdestlen(Head.UnCompressedSize));
Head.UnCompressedSize := S.Read(pointer(src)^,Head.UnCompressedSize);
{$ifdef MSWINDOWS}
if (Head.UnCompressedSize<=0) and
(GetLastError=ERROR_NO_SYSTEM_RESOURCES) then begin
Max := 32 shl 20; // we observed a 32MB chunk size limitation on XP
Head.UnCompressedSize := S.Read(pointer(src)^,Max);
end;
{$endif MSWINDOWS}
if Head.UnCompressedSize<=0 then
exit; // read error
Head.HashUncompressed := Hash32(pointer(src),Head.UnCompressedSize);
Head.CompressedSize :=
SynLZcompress1(pointer(src),Head.UnCompressedSize,pointer(dst));
Head.HashCompressed := Hash32(pointer(dst),Head.CompressedSize);
if (D.Write(Head,SizeOf(Head))<>SizeOf(Head)) or
(D.Write(pointer(dst)^,Head.CompressedSize)<>Head.CompressedSize) then
exit;
dec(Count,Head.UnCompressedSize);
end;
finally
D.Free;
end;
result := FileSetDateFrom(Dest,S.Handle);
finally
S.Free;
end;
except
on Exception do
result := false;
end;
end;
function FileUnSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean;
var src,dst: RawByteString;
S,D: THandleStream;
Count: Int64;
Head: TSynLZHead;
begin
result := false;
if FileExists(Source) then
try
S := FileStreamSequentialRead(Source);
try
DeleteFile(Dest);
D := TFileStream.Create(Dest,fmCreate);
try
Count := S.Size;
while Count>0 do begin
if S.Read(Head,SizeOf(Head))<>SizeOf(Head) then
exit;
dec(Count,SizeOf(Head));
if (Head.Magic<>Magic) or
(Head.CompressedSize>Count) then
exit;
if Head.CompressedSize>length(src) then
SetString(src,nil,Head.CompressedSize);
if S.Read(pointer(src)^,Head.CompressedSize)<>Head.CompressedSize then
exit;
dec(Count,Head.CompressedSize);
if (Hash32(pointer(src),Head.CompressedSize)<>Head.HashCompressed) or
(SynLZdecompressdestlen(pointer(src))<>Head.UnCompressedSize) then
exit;
if Head.UnCompressedSize>length(dst) then
SetString(dst,nil,Head.UnCompressedSize);
if (SynLZDecompress1(pointer(src),Head.CompressedSize,pointer(dst))<>Head.UnCompressedSize) or
(Hash32(pointer(dst),Head.UnCompressedSize)<>Head.HashUncompressed) then
exit;
if D.Write(pointer(dst)^,Head.UncompressedSize)<>Head.UncompressedSize then
exit;
end;
finally
D.Free;
end;
result := FileSetDateFrom(Dest,S.Handle);
finally
S.Free;
end;
except
on Exception do
result := false;
end;
end;
function FileIsSynLZ(const Name: TFileName; Magic: Cardinal): boolean;
var S: TFileStream;
Head: TSynLZHead;
begin
result := false;
if FileExists(Name) then
try
S := TFileStream.Create(Name,fmOpenRead or fmShareDenyNone);
try
if S.Read(Head,SizeOf(Head))=SizeOf(Head) then
if Head.Magic=Magic then
result := true; // only check magic, since there may be several chunks
finally
S.Free;
end;
except
on Exception do
result := false;
end;
end;
function StreamUnSynLZ(const Source: TFileName; Magic: cardinal): TMemoryStream;
var S: TStream;
begin
try
S := TSynMemoryStreamMapped.Create(Source);
try
result := StreamUnSynLZ(S,Magic);
finally
S.Free;
end;
except
on E: Exception do
result := nil;
end;
end;
function StreamUnSynLZ(Source: TStream; Magic: cardinal): TMemoryStream;
var S,D: PAnsiChar;
sourcePosition,resultSize,sourceSize: Int64;
Head: TSynLZHead;
Trailer: TSynLZTrailer;
buf: RawByteString;
stored: boolean;
begin
result := nil;
if Source=nil then
exit;
sourceSize := Source.Size;
{$ifndef CPU64}
if sourceSize>maxInt then
exit; // result TMemoryStream should stay in memory!
{$endif}
sourcePosition := Source.Position;
if sourceSize-sourcePosition<SizeOf(head) then
exit;
resultSize := 0;
repeat
if (Source.Read(Head,SizeOf(Head))<>SizeOf(Head)) or
(Head.Magic<>Magic) then begin
// Source not positioned as expected -> try from the end
Source.Position := sourceSize-SizeOf(Trailer);
if (Source.Read(Trailer,SizeOf(Trailer))<>SizeOf(Trailer)) or
(Trailer.Magic<>Magic) then
exit;
sourcePosition := sourceSize-Trailer.HeaderRelativeOffset;
Source.Position := sourcePosition;
if (Source.Read(Head,SizeOf(Head))<>SizeOf(Head)) or
(Head.Magic<>Magic) then
exit;
end;
inc(sourcePosition,SizeOf(Head));
if sourcePosition+Head.CompressedSize>sourceSize then
exit;
if Source.InheritsFrom(TCustomMemoryStream) then begin
S := PAnsiChar(TCustomMemoryStream(Source).Memory)+PtrUInt(sourcePosition);
Source.Seek(Head.CompressedSize,soCurrent);
end else begin
if Head.CompressedSize>length(Buf) then
SetString(Buf,nil,Head.CompressedSize);
S := pointer(Buf);
Source.Read(S^,Head.CompressedSize);
end;
inc(sourcePosition,Head.CompressedSize);
if (Source.Read(Trailer,SizeOf(Trailer))<>SizeOf(Trailer)) or
(Trailer.Magic<>Magic) then
// trailer not available in old .synlz layout, or in FileSynLZ multiblocks
Source.Position := sourcePosition else
sourceSize := 0; // should be monoblock
// Source stream will now point after all data
stored := (Head.CompressedSize=Head.UnCompressedSize) and
(Head.HashCompressed=Head.HashUncompressed);
if not stored then
if SynLZdecompressdestlen(S)<>Head.UnCompressedSize then
exit;
if Hash32(pointer(S),Head.CompressedSize)<>Head.HashCompressed then
exit;
if result=nil then
result := THeapMemoryStream.Create else begin
{$ifndef CPU64}
if resultSize+Head.UnCompressedSize>maxInt then begin
FreeAndNil(result); // result TMemoryStream should stay in memory!
break;
end;
{$endif CPU64}
end;
result.Size := resultSize+Head.UnCompressedSize;
D := PAnsiChar(result.Memory)+resultSize;
inc(resultSize,Head.UnCompressedSize);
if stored then
MoveFast(S^,D^,Head.CompressedSize) else
if SynLZDecompress1(S,Head.CompressedSize,D)<>Head.UnCompressedSize then
FreeAndNil(result) else
if Hash32(pointer(D),Head.UnCompressedSize)<>Head.HashUncompressed then
FreeAndNil(result);
until (result=nil) or (sourcePosition>=sourceSize);
end;
{ TAlgoCompress }
const
COMPRESS_STORED = #0;
COMPRESS_SYNLZ = 1;
var
SynCompressAlgos: TSynObjectList;
constructor TAlgoCompress.Create;
var existing: TAlgoCompress;
begin
inherited Create;
if SynCompressAlgos=nil then
GarbageCollectorFreeAndNil(SynCompressAlgos,TSynObjectList.Create) else begin
existing := Algo(AlgoID);
if existing<>nil then
raise ESynException.CreateUTF8('%.Create: AlgoID=% already registered by %',
[self,AlgoID,existing.ClassType]);
end;
SynCompressAlgos.Add(self);
end;
class function TAlgoCompress.Algo(const Comp: RawByteString): TAlgoCompress;
begin
result := Algo(Pointer(Comp),Length(Comp));
end;
class function TAlgoCompress.Algo(const Comp: TByteDynArray): TAlgoCompress;
begin
result := Algo(Pointer(Comp),Length(Comp));
end;
class function TAlgoCompress.Algo(Comp: PAnsiChar; CompLen: integer): TAlgoCompress;
begin
if (Comp<>nil) and (CompLen>9) then
if ord(Comp[4])<=1 then // inline-friendly Comp[4]<=COMPRESS_SYNLZ
result := AlgoSynLZ else // COMPRESS_STORED is also handled as SynLZ
result := Algo(ord(Comp[4])) else
result := nil;
end;
class function TAlgoCompress.Algo(Comp: PAnsiChar; CompLen: integer; out IsStored: boolean): TAlgoCompress;
begin
if (Comp<>nil) and (CompLen>9) then begin
IsStored := Comp[4]=COMPRESS_STORED;
result := Algo(ord(Comp[4]));
end else begin
IsStored := false;
result := nil;
end;
end;
class function TAlgoCompress.Algo(AlgoID: byte): TAlgoCompress;
var i: integer;
ptr: ^TAlgoCompress;
begin
if AlgoID<=COMPRESS_SYNLZ then // COMPRESS_STORED is handled as SynLZ
result := AlgoSynLZ else begin
if SynCompressAlgos<>nil then begin
ptr := pointer(SynCompressAlgos.List);
inc(ptr); // ignore List[0] = AlgoSynLZ
for i := 2 to SynCompressAlgos.Count do
if ptr^.AlgoID=AlgoID then begin
result := ptr^;
exit;
end
else
inc(ptr);
end;
result := nil;
end;
end;
class function TAlgoCompress.UncompressedSize(const Comp: RawByteString): integer;
begin
result := Algo(Comp).DecompressHeader(pointer(Comp),length(Comp));
end;
function TAlgoCompress.AlgoName: TShort16;
var s: PShortString;
i: integer;
begin
if self=nil then
result := 'none' else begin
s := ClassNameShort(self);
if IdemPChar(@s^[1],'TALGO') then begin
result[0] := AnsiChar(ord(s^[0])-5);
inc(PByte(s),5);
end else
result[0] := s^[0];
if result[0]>#16 then
result[0] := #16;
for i := 1 to ord(result[0]) do
result[i] := NormToLower[s^[i]];
end;
end;
function TAlgoCompress.AlgoHash(Previous: cardinal; Data: pointer; DataLen: integer): cardinal;
begin
result := crc32c(Previous,Data,DataLen);
end;
function TAlgoCompress.Compress(const Plain: RawByteString; CompressionSizeTrigger: integer;
CheckMagicForCompressed: boolean; BufferOffset: integer): RawByteString;
begin
result := Compress(pointer(Plain),Length(Plain),CompressionSizeTrigger,
CheckMagicForCompressed,BufferOffset);
end;
function TAlgoCompress.Compress(Plain: PAnsiChar; PlainLen: integer; CompressionSizeTrigger: integer;
CheckMagicForCompressed: boolean; BufferOffset: integer): RawByteString;
var len: integer;
R: PAnsiChar;
crc: cardinal;
tmp: array[0..16383] of AnsiChar; // big enough to resize Result in-place
begin
if (self=nil) or (PlainLen=0) or (Plain=nil) then begin
result := '';
exit;
end;
crc := AlgoHash(0,Plain,PlainLen);
if (PlainLen<CompressionSizeTrigger) or
(CheckMagicForCompressed and IsContentCompressed(Plain,PlainLen)) then begin
SetString(result,nil,PlainLen+BufferOffset+9);
R := pointer(result);
inc(R,BufferOffset);
PCardinal(R)^ := crc;
R[4] := COMPRESS_STORED;
PCardinal(R+5)^ := crc;
MoveFast(Plain^,R[9],PlainLen);
end else begin
len := CompressDestLen(PlainLen)+BufferOffset;
if len>SizeOf(tmp) then begin
SetString(result,nil,len);
R := pointer(result);
end else
R := @tmp;
inc(R,BufferOffset);
PCardinal(R)^ := crc;
len := AlgoCompress(Plain,PlainLen,R+9);
if len+64>=PlainLen then begin // store if compression was not worth it
R[4] := COMPRESS_STORED;
PCardinal(R+5)^ := crc;
MoveFast(Plain^,R[9],PlainLen);
len := PlainLen;
end else begin
R[4] := AnsiChar(AlgoID);
PCardinal(R+5)^ := AlgoHash(0,R+9,len);
end;
if R=@tmp[BufferOffset] then
SetString(result,tmp,len+BufferOffset+9) else
SetLength(result,len+BufferOffset+9); // MM may not move the data
end;
end;
function TAlgoCompress.Compress(Plain, Comp: PAnsiChar; PlainLen, CompLen: integer;
CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean): integer;
var len: integer;
begin
result := 0;
if (self=nil) or (PlainLen=0) or (CompLen<PlainLen+9) then
exit;
PCardinal(Comp)^ := AlgoHash(0,Plain,PlainLen);
if (PlainLen>=CompressionSizeTrigger) and
not(CheckMagicForCompressed and IsContentCompressed(Plain,PlainLen)) then begin
len := CompressDestLen(PlainLen);
if CompLen<len then
exit;
len := AlgoCompress(Plain,PlainLen,Comp+9);
if len<PlainLen then begin
Comp[4] := AnsiChar(AlgoID);
PCardinal(Comp+5)^ := AlgoHash(0,Comp+9,len);
result := len+9;
exit;
end;
end;
Comp[4] := COMPRESS_STORED;
PCardinal(Comp+5)^ := PCardinal(Comp)^;
MoveFast(Plain^,Comp[9],PlainLen);
result := PlainLen+9;
end;
function TAlgoCompress.CompressDestLen(PlainLen: integer): integer;
begin
if self=nil then
result := 0 else
result := AlgoCompressDestLen(PLainLen)+9;
end;
function TAlgoCompress.CompressToBytes(Plain: PAnsiChar; PlainLen: integer;
CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean): TByteDynArray;
var len: integer;
R: PAnsiChar;
crc: cardinal;
begin
Finalize(result);
if (self=nil) or (PlainLen=0) then
exit;
crc := AlgoHash(0,Plain,PlainLen);
if PlainLen<CompressionSizeTrigger then begin
SetLength(result,PlainLen+9);
R := pointer(result);
PCardinal(R)^ := crc;
R[4] := COMPRESS_STORED;
PCardinal(R+5)^ := crc;
MoveFast(Plain^,R[9],PlainLen);
end else begin
SetLength(result,CompressDestLen(PlainLen));
R := pointer(result);
PCardinal(R)^ := crc;
len := AlgoCompress(Plain,PlainLen,R+9);
if len>=PlainLen then begin // store if compression not worth it
R[4] := COMPRESS_STORED;
PCardinal(R+5)^ := crc;
MoveFast(Plain^,R[9],PlainLen);
len := PlainLen;
end else begin
R[4] := AnsiChar(AlgoID);
PCardinal(R+5)^ := AlgoHash(0,R+9,len);
end;
SetLength(result,len+9);
end;
end;
function TAlgoCompress.CompressToBytes(const Plain: RawByteString;
CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean): TByteDynArray;
begin
result := CompressToBytes(pointer(Plain),Length(Plain),
CompressionSizeTrigger,CheckMagicForCompressed);
end;
function TAlgoCompress.Decompress(const Comp: TByteDynArray): RawByteString;
begin
Decompress(pointer(Comp),length(Comp),result);
end;
procedure TAlgoCompress.Decompress(Comp: PAnsiChar; CompLen: integer;
out Result: RawByteString; Load: TAlgoCompressLoad; BufferOffset: integer);
var len: integer;
dec: PAnsiChar;
begin
len := DecompressHeader(Comp,CompLen,Load);
if len=0 then
exit;
SetString(result,nil,len+BufferOffset);
dec := pointer(result);
if not DecompressBody(Comp,dec+BufferOffset,CompLen,len,Load) then
result := '';
end;
function TAlgoCompress.Decompress(const Comp: RawByteString;
Load: TAlgoCompressLoad; BufferOffset: integer): RawByteString;
begin
Decompress(pointer(Comp),length(Comp),result,Load,BufferOffset);
end;
function TAlgoCompress.TryDecompress(const Comp: RawByteString;
out Dest: RawByteString; Load: TAlgoCompressLoad): boolean;
var len: integer;
begin
result := Comp='';
if result then
exit;
len := DecompressHeader(pointer(Comp),length(Comp),Load);
if len=0 then
exit; // invalid crc32c
SetString(Dest,nil,len);
if DecompressBody(pointer(Comp),pointer(Dest),length(Comp),len,Load) then
result := true else
Dest := '';
end;
function TAlgoCompress.Decompress(const Comp: RawByteString;
out PlainLen: integer; var tmp: RawByteString; Load: TAlgoCompressLoad): pointer;
begin
result := Decompress(pointer(Comp),length(Comp),PlainLen,tmp,Load);
end;
function TAlgoCompress.Decompress(Comp: PAnsiChar; CompLen: integer;
out PlainLen: integer; var tmp: RawByteString; Load: TAlgoCompressLoad): pointer;
begin
result := nil;
PlainLen := DecompressHeader(Comp,CompLen,Load);
if PlainLen=0 then
exit;
if Comp[4]=COMPRESS_STORED then
result := Comp+9 else begin
if PlainLen > length(tmp) then
SetString(tmp,nil,PlainLen);
if DecompressBody(Comp,pointer(tmp),CompLen,PlainLen,Load) then
result := pointer(tmp);
end;
end;
function TAlgoCompress.DecompressPartial(Comp, Partial: PAnsiChar;
CompLen, PartialLen, PartialLenMax: integer): integer;
var BodyLen: integer;
begin
result := 0;
if (self=nil) or (CompLen<=9) or (Comp=nil) or (PartialLenMax<PartialLen) then
exit;
if Comp[4]=COMPRESS_STORED then
if PCardinal(Comp)^=PCardinal(Comp+5)^ then
BodyLen := CompLen-9 else
exit
else if Comp[4]=AnsiChar(AlgoID) then
BodyLen := AlgoDecompressDestLen(Comp+9) else
exit;
if PartialLen>BodyLen then
PartialLen := BodyLen;
if Comp[4]=COMPRESS_STORED then
MoveFast(Comp[9],Partial[0],PartialLen) else
if AlgoDecompressPartial(Comp+9,CompLen-9,Partial,PartialLen,PartialLenMax)<PartialLen then
exit;
result := PartialLen;
end;
function TAlgoCompress.DecompressHeader(Comp: PAnsiChar; CompLen: integer;
Load: TAlgoCompressLoad): integer;
begin
result := 0;
if (self=nil) or (CompLen<=9) or (Comp=nil) or
((Load<>aclNoCrcFast) and (AlgoHash(0,Comp+9,CompLen-9)<>PCardinal(Comp+5)^)) then
exit;
if Comp[4]=COMPRESS_STORED then begin
if PCardinal(Comp)^=PCardinal(Comp+5)^ then
result := CompLen-9;
end else
if Comp[4]=AnsiChar(AlgoID) then
result := AlgoDecompressDestLen(Comp+9);
end;
function TAlgoCompress.DecompressBody(Comp, Plain: PAnsiChar;
CompLen, PlainLen: integer; Load: TAlgoCompressLoad): boolean;
begin
result := false;
if (self=nil) or (PlainLen<=0) then
exit;
if Comp[4]=COMPRESS_STORED then
MoveFast(Comp[9],Plain[0],PlainLen) else
if Comp[4]=AnsiChar(AlgoID) then
case Load of
aclNormal:
if (AlgoDecompress(Comp+9,CompLen-9,Plain)<>PlainLen) or
(AlgoHash(0,Plain,PlainLen)<>PCardinal(Comp)^) then
exit;
aclSafeSlow:
if (AlgoDecompressPartial(Comp+9,CompLen-9,Plain,PlainLen,PlainLen)<>PlainLen) or
(AlgoHash(0,Plain,PlainLen)<>PCardinal(Comp)^) then
exit;
aclNoCrcFast:
if (AlgoDecompress(Comp+9,CompLen-9,Plain)<>PlainLen) then
exit;
end;
result := true;
end;
{ TAlgoSynLZ }
function TAlgoSynLZ.AlgoID: byte;
begin
result := COMPRESS_SYNLZ; // =1
end;
function TAlgoSynLZ.AlgoCompress(Plain: pointer; PlainLen: integer;
Comp: pointer): integer;
begin
result := SynLZcompress1(Plain,PlainLen,Comp);
end;
function TAlgoSynLZ.AlgoCompressDestLen(PlainLen: integer): integer;
begin
result := SynLZcompressdestlen(PlainLen);
end;
function TAlgoSynLZ.AlgoDecompress(Comp: pointer; CompLen: integer;
Plain: pointer): integer;
begin
result := SynLZdecompress1(Comp,CompLen,Plain);
end;
function TAlgoSynLZ.AlgoDecompressDestLen(Comp: pointer): integer;
begin
result := SynLZdecompressdestlen(Comp);
end;
function TAlgoSynLZ.AlgoDecompressPartial(Comp: pointer;
CompLen: integer; Partial: pointer; PartialLen, PartialLenMax: integer): integer;
begin
result := SynLZdecompress1partial(Comp,CompLen,Partial,PartialLen);
end;
// deprecated wrapper methods - use SynLZ global variable instead
function SynLZCompress(const Data: RawByteString; CompressionSizeTrigger: integer;
CheckMagicForCompressed: boolean): RawByteString;
begin
result := AlgoSynLZ.Compress(pointer(Data),length(Data),CompressionSizeTrigger,
CheckMagicForCompressed);
end;
procedure SynLZCompress(P: PAnsiChar; PLen: integer; out Result: RawByteString;
CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean);
begin
result := AlgoSynLZ.Compress(P,PLen,CompressionSizeTrigger,CheckMagicForCompressed);
end;
function SynLZCompress(P, Dest: PAnsiChar; PLen, DestLen: integer;
CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean): integer;
begin
result := AlgoSynLZ.Compress(P,Dest,PLen,DestLen,CompressionSizeTrigger,CheckMagicForCompressed);
end;
function SynLZDecompress(const Data: RawByteString): RawByteString;
begin
AlgoSynLZ.Decompress(pointer(Data),Length(Data),result);
end;
function SynLZDecompressHeader(P: PAnsiChar; PLen: integer): integer;
begin
result := AlgoSynLZ.DecompressHeader(P,PLen);
end;
function SynLZDecompressBody(P,Body: PAnsiChar; PLen,BodyLen: integer;
SafeDecompression: boolean): boolean;
begin
result := AlgoSynLZ.DecompressBody(P,Body,PLen,BodyLen,ALGO_SAFE[SafeDecompression]);
end;
function SynLZDecompressPartial(P,Partial: PAnsiChar; PLen,PartialLen: integer): integer;
begin
result := AlgoSynLZ.DecompressPartial(P,Partial,PLen,PartialLen,PartialLen);
end;
procedure SynLZDecompress(P: PAnsiChar; PLen: integer; out Result: RawByteString;
SafeDecompression: boolean);
begin
AlgoSynLZ.Decompress(P,PLen,Result);
end;
function SynLZDecompress(const Data: RawByteString; out Len: integer;
var tmp: RawByteString): pointer;
begin
result := AlgoSynLZ.Decompress(pointer(Data),length(Data),Len,tmp);
end;
function SynLZDecompress(P: PAnsiChar; PLen: integer; out Len: integer;
var tmp: RawByteString): pointer;
begin
result := AlgoSynLZ.Decompress(P,PLen,Len,tmp);
end;
function SynLZCompressToBytes(const Data: RawByteString;
CompressionSizeTrigger: integer): TByteDynArray;
begin
result := AlgoSynLZ.CompressToBytes(pointer(Data),length(Data),CompressionSizeTrigger);
end;
function SynLZCompressToBytes(P: PAnsiChar; PLen,CompressionSizeTrigger: integer): TByteDynArray;
begin
result := AlgoSynLZ.CompressToBytes(P,PLen,CompressionSizeTrigger);
end;
function SynLZDecompress(const Data: TByteDynArray): RawByteString;
begin
AlgoSynLZ.Decompress(pointer(Data),length(Data),result);
end;
{ TAlgoCompressWithNoDestLen }
function TAlgoCompressWithNoDestLen.AlgoCompress(Plain: pointer;
PlainLen: integer; Comp: pointer): integer;
begin
Comp := ToVarUInt32(PlainLen,Comp); // deflate don't store PlainLen
result := RawProcess(Plain,Comp,PlainLen,AlgoCompressDestLen(PlainLen),0,doCompress);
if result>0 then
inc(result,ToVarUInt32Length(PlainLen));
end;
function TAlgoCompressWithNoDestLen.AlgoDecompress(Comp: pointer;
CompLen: integer; Plain: pointer): integer;
var start: PAnsiChar;
begin
start := Comp;
result := FromVarUInt32(PByte(Comp));
if RawProcess(Comp,Plain,CompLen+(Start-Comp),result,0,doUnCompress)<>result then
result := 0;
end;
function TAlgoCompressWithNoDestLen.AlgoDecompressDestLen(Comp: pointer): integer;
begin
if Comp=nil then
result := 0 else
result := FromVarUInt32(PByte(Comp));
end;
function TAlgoCompressWithNoDestLen.AlgoDecompressPartial(Comp: pointer;
CompLen: integer; Partial: pointer; PartialLen, PartialLenMax: integer): integer;
var start: PAnsiChar;
begin
start := Comp;
result := FromVarUInt32(PByte(Comp));
if PartialLenMax>result then
PartialLenMax := result;
result := RawProcess(Comp,Partial,CompLen+(Start-Comp),PartialLen,PartialLenMax,doUncompressPartial);
end;
{ ESynException }
constructor ESynException.CreateUTF8(const Format: RawUTF8; const Args: array of const);
var msg: string;
begin
FormatString(Format,Args,msg);
inherited Create(msg);
end;
constructor ESynException.CreateLastOSError(
const Format: RawUTF8; const Args: array of const; const Trailer: RawUtf8);
var tmp: RawUTF8;
error: integer;
begin
error := GetLastError;
FormatUTF8(Format,Args,tmp);
CreateUTF8('% % [%] %',[Trailer,error,SysErrorMessage(error),tmp]);
end;
{$ifndef NOEXCEPTIONINTERCEPT}
function ESynException.CustomLog(WR: TTextWriter;
const Context: TSynLogExceptionContext): boolean;
begin
if Assigned(TSynLogExceptionToStrCustom) then
result := TSynLogExceptionToStrCustom(WR,Context) else
if Assigned(DefaultSynLogExceptionToStr) then
result := DefaultSynLogExceptionToStr(WR,Context) else
result := false;
end;
{$endif}
{ TMemoryMapText }
constructor TMemoryMapText.Create;
begin
end;
constructor TMemoryMapText.Create(aFileContent: PUTF8Char; aFileSize: integer);
begin
Create;
fMap.Map(aFileContent,aFileSize);
LoadFromMap;
end;
constructor TMemoryMapText.Create(const aFileName: TFileName);
begin
Create;
fFileName := aFileName;
if fMap.Map(aFileName) then
LoadFromMap;
end; // invalid file or unable to memory map its content -> Count := 0
destructor TMemoryMapText.Destroy;
begin
Freemem(fLines);
fMap.UnMap;
inherited;
end;
procedure TMemoryMapText.SaveToStream(Dest: TStream; const Header: RawUTF8);
var i: integer;
W: TTextWriter;
temp: TTextWriterStackBuffer;
begin
i := length(Header);
if i>0 then
Dest.WriteBuffer(pointer(Header)^,i);
if fMap.Size>0 then
Dest.WriteBuffer(fMap.Buffer^,fMap.Size);
if fAppendedLinesCount=0 then
exit;
W := TTextWriter.Create(Dest,@temp,SizeOf(temp));
try
if (fMap.Size>0) and (fMap.Buffer[fMap.Size-1]>=' ') then
W.Add(#10);
for i := 0 to fAppendedLinesCount-1 do begin
W.AddString(fAppendedLines[i]);
W.Add(#10);
end;
W.FlushFinal;
finally
W.Free;
end;
end;
procedure TMemoryMapText.SaveToFile(FileName: TFileName; const Header: RawUTF8);
var FS: TFileStream;
begin
FS := TFileStream.Create(FileName,fmCreate);
try
SaveToStream(FS,Header);
finally
FS.Free;
end;
end;
function TMemoryMapText.GetLine(aIndex: integer): RawUTF8;
begin
if (self=nil) or (cardinal(aIndex)>=cardinal(fCount)) then
result := '' else
FastSetString(result,fLines[aIndex],GetLineSize(fLines[aIndex],fMapEnd));
end;
function TMemoryMapText.GetString(aIndex: integer): string;
begin
if (self=nil) or (cardinal(aIndex)>=cardinal(fCount)) then
result := '' else
UTF8DecodeToString(fLines[aIndex],GetLineSize(fLines[aIndex],fMapEnd),result);
end;
function GetLineContains(p, pEnd, up: PUTF8Char): boolean;
var
i: PtrInt;
{$ifdef CPUX86NOTPIC} table: TNormTable absolute NormToUpperAnsi7Byte;
{$else} table: PNormTable; {$endif}
label
Fnd1, LF1, Fnd2, LF2, Ok; // ugly but fast
begin
if (p<>nil) and (up<>nil) then begin
{$ifndef CPUX86NOTPIC} table := @NormToUpperAnsi7; {$endif}
if pEnd=nil then
repeat
if p^<=#13 then
goto LF1
else if table[p^]=up^ then
goto Fnd1;
inc(p);
continue;
LF1: if (p^=#0) or (p^=#13) or (p^=#10) then
break;
inc(p);
continue;
Fnd1: i := 0;
repeat
inc(i);
if up[i]<>#0 then
if up[i]=table[p[i]] then
continue else
break else begin
Ok: result := true; // found
exit;
end;
until false;
inc(p);
until false
else
repeat
if p>=pEnd then
break;
if p^<=#13 then
goto LF2
else if table[p^]=up^ then
goto Fnd2;
inc(p);
continue;
LF2: if (p^=#13) or (p^=#10) then
break;
inc(p);
continue;
Fnd2: i := 0;
repeat
inc(i);
if up[i]=#0 then
goto Ok;
if p+i>=pEnd then
break;
until up[i]<>table[p[i]];
inc(p);
until false;
end;
result := false;
end;
function TMemoryMapText.LineContains(const aUpperSearch: RawUTF8;
aIndex: Integer): Boolean;
begin
if (self=nil) or (cardinal(aIndex)>=cardinal(fCount)) or (aUpperSearch='') then
result := false else
result := GetLineContains(fLines[aIndex],fMapEnd,pointer(aUpperSearch));
end;
function TMemoryMapText.LineSize(aIndex: integer): integer;
begin
result := GetLineSize(fLines[aIndex],fMapEnd);
end;
function GetLineSizeSmallerThan(P,PEnd: PUTF8Char; aMinimalCount: integer): boolean;
begin
if P<>nil then
while (P<PEnd) and (P^<>#10) and (P^<>#13) do
if aMinimalCount=0 then begin
result := false;
exit;
end else begin
dec(aMinimalCount);
inc(P);
end;
result := true;
end;
function TMemoryMapText.LineSizeSmallerThan(aIndex, aMinimalCount: integer): boolean;
begin
result := GetLineSizeSmallerThan(fLines[aIndex],fMapEnd,aMinimalCount);
end;
procedure TMemoryMapText.ProcessOneLine(LineBeg, LineEnd: PUTF8Char);
begin
if fCount=fLinesMax then begin
fLinesMax := NextGrow(fLinesMax);
ReallocMem(fLines,fLinesMax*SizeOf(pointer));
end;
fLines[fCount] := LineBeg;
inc(fCount);
end;
procedure TMemoryMapText.LoadFromMap(AverageLineLength: integer=32);
procedure ParseLines(P,PEnd: PUTF8Char);
var PBeg: PUTF8Char;
begin // generated asm is much better with a local proc
while P<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;
{ TSynNameValue }
procedure TSynNameValue.Add(const aName, aValue: RawUTF8; aTag: PtrInt);
var added: boolean;
i: Integer;
begin
i := DynArray.FindHashedForAdding(aName,added);
with List[i] do begin
if added then
Name := aName;
Value := aValue;
Tag := aTag;
end;
if Assigned(fOnAdd) then
fOnAdd(List[i],i);
end;
procedure TSynNameValue.InitFromIniSection(Section: PUTF8Char;
OnTheFlyConvert: TOnSynNameValueConvertRawUTF8; OnAdd: TOnSynNameValueNotify);
var s: RawUTF8;
i: integer;
begin
Init(false);
fOnAdd := OnAdd;
while (Section<>nil) and (Section^<>'[') do begin
s := GetNextLine(Section,Section);
i := PosExChar('=',s);
if (i>1) and not(s[1] in [';','[']) then
if Assigned(OnTheFlyConvert) then
Add(copy(s,1,i-1),OnTheFlyConvert(copy(s,i+1,1000))) else
Add(copy(s,1,i-1),copy(s,i+1,1000));
end;
end;
procedure TSynNameValue.InitFromCSV(CSV: PUTF8Char; NameValueSep,ItemSep: AnsiChar);
var n,v: RawUTF8;
begin
Init(false);
while CSV<>nil do begin
GetNextItem(CSV,NameValueSep,n);
if ItemSep=#10 then
GetNextItemTrimedCRLF(CSV,v) else
GetNextItem(CSV,ItemSep,v);
if n='' then
break;
Add(n,v);
end;
end;
procedure TSynNameValue.InitFromNamesValues(const Names, Values: array of RawUTF8);
var i: integer;
begin
Init(false);
if high(Names)<>high(Values) then
exit;
DynArray.SetCapacity(length(Names));
for i := 0 to high(Names) do
Add(Names[i],Values[i]);
end;
function TSynNameValue.InitFromJSON(JSON: PUTF8Char; aCaseSensitive: boolean): boolean;
var N,V: PUTF8Char;
nam,val: RawUTF8;
Nlen, Vlen, c: integer;
EndOfObject: AnsiChar;
begin
result := false;
Init(aCaseSensitive);
if JSON=nil then
exit;
while (JSON^<=' ') and (JSON^<>#0) do inc(JSON);
if JSON^<>'{' then
exit;
repeat inc(JSON) until (JSON^=#0) or (JSON^>' ');
c := JSONObjectPropCount(JSON);
if c<=0 then
exit;
DynArray.SetCapacity(c);
repeat
N := GetJSONPropName(JSON,@Nlen);
if N=nil then
exit;
V := GetJSONFieldOrObjectOrArray(JSON,nil,@EndOfObject,true,true,@Vlen);
if V=nil then
exit;
FastSetString(nam,N,Nlen);
FastSetString(val,V,Vlen);
Add(nam,val);
until EndOfObject='}';
result := true;
end;
procedure TSynNameValue.Init(aCaseSensitive: boolean);
begin
// release dynamic arrays memory before FillcharFast()
List := nil;
DynArray.fHash.Clear;
// initialize hashed storage
FillCharFast(self,SizeOf(self),0);
DynArray.InitSpecific(TypeInfo(TSynNameValueItemDynArray),List,
djRawUTF8,@Count,not aCaseSensitive);
end;
function TSynNameValue.Find(const aName: RawUTF8): integer;
begin
result := DynArray.FindHashed(aName);
end;
function TSynNameValue.FindStart(const aUpperName: RawUTF8): integer;
begin
for result := 0 to Count-1 do
if IdemPChar(pointer(List[result].Name),pointer(aUpperName)) then
exit;
result := -1;
end;
function TSynNameValue.FindByValue(const aValue: RawUTF8): integer;
begin
for result := 0 to Count-1 do
if List[result].Value=aValue then
exit;
result := -1;
end;
function TSynNameValue.Delete(const aName: RawUTF8): boolean;
begin
result := DynArray.FindHashedAndDelete(aName)>=0;
end;
function TSynNameValue.DeleteByValue(const aValue: RawUTF8; Limit: integer): integer;
var ndx: integer;
begin
result := 0;
if Limit<1 then
exit;
for ndx := Count-1 downto 0 do
if List[ndx].Value=aValue then begin
DynArray.Delete(ndx);
inc(result);
if result>=Limit then
break;
end;
if result>0 then
DynArray.ReHash;
end;
function TSynNameValue.Value(const aName: RawUTF8; const aDefaultValue: RawUTF8): RawUTF8;
var i: integer;
begin
if @self=nil then
i := -1 else
i := DynArray.FindHashed(aName);
if i<0 then
result := aDefaultValue else
result := List[i].Value;
end;
function TSynNameValue.ValueInt(const aName: RawUTF8; const aDefaultValue: Int64): Int64;
var i,err: integer;
begin
i := DynArray.FindHashed(aName);
if i<0 then
result := aDefaultValue else begin
result := {$ifdef CPU64}GetInteger{$else}GetInt64{$endif}(pointer(List[i].Value),err);
if err<>0 then
result := aDefaultValue;
end;
end;
function TSynNameValue.ValueBool(const aName: RawUTF8): Boolean;
begin
result := Value(aName)='1';
end;
function TSynNameValue.ValueEnum(const aName: RawUTF8; aEnumTypeInfo: pointer;
out aEnum; aEnumDefault: byte): boolean;
var v: RawUTF8;
err,i: integer;
begin
result := false;
byte(aEnum) := aEnumDefault;
v := trim(Value(aName,''));
if v='' then
exit;
i := GetInteger(pointer(v),err);
if (err<>0) or (i<0) then
i := GetEnumNameValue(aEnumTypeInfo,v,true);
if i>=0 then begin
byte(aEnum) := i;
result := true;
end;
end;
function TSynNameValue.Initialized: boolean;
begin
result := DynArray.Value=@List;
end;
function TSynNameValue.GetBlobData: RawByteString;
begin
result := DynArray.SaveTo;
end;
procedure TSynNameValue.SetBlobDataPtr(aValue: pointer);
begin
DynArray.LoadFrom(aValue);
DynArray.ReHash;
end;
procedure TSynNameValue.SetBlobData(const aValue: RawByteString);
begin
DynArray.LoadFromBinary(aValue);
DynArray.ReHash;
end;
function TSynNameValue.GetStr(const aName: RawUTF8): RawUTF8;
begin
result := Value(aName,'');
end;
function TSynNameValue.GetInt(const aName: RawUTF8): Int64;
begin
result := ValueInt(aName,0);
end;
function TSynNameValue.GetBool(const aName: RawUTF8): Boolean;
begin
result := Value(aName)='1';
end;
function TSynNameValue.AsCSV(const KeySeparator,ValueSeparator,IgnoreKey: RawUTF8): RawUTF8;
var i: integer;
temp: TTextWriterStackBuffer;
begin
with TTextWriter.CreateOwnedStream(temp) do
try
for i := 0 to Count-1 do
if (IgnoreKey='') or (List[i].Name<>IgnoreKey) then begin
AddNoJSONEscapeUTF8(List[i].Name);
AddNoJSONEscapeUTF8(KeySeparator);
AddNoJSONEscapeUTF8(List[i].Value);
AddNoJSONEscapeUTF8(ValueSeparator);
end;
SetText(result);
finally
Free;
end;
end;
function TSynNameValue.AsJSON: RawUTF8;
var i: integer;
temp: TTextWriterStackBuffer;
begin
with TTextWriter.CreateOwnedStream(temp) do
try
Add('{');
for i := 0 to Count-1 do
with List[i] do begin
AddProp(pointer(Name),length(Name));
Add('"');
AddJSONEscape(pointer(Value));
Add('"',',');
end;
CancelLastComma;
Add('}');
SetText(result);
finally
Free;
end;
end;
procedure TSynNameValue.AsNameValues(out Names,Values: TRawUTF8DynArray);
var i: integer;
begin
SetLength(Names,Count);
SetLength(Values,Count);
for i := 0 to Count-1 do begin
Names[i] := List[i].Name;
Values[i] := List[i].Value;
end;
end;
{$ifndef NOVARIANTS}
function TSynNameValue.ValueVariantOrNull(const aName: RawUTF8): variant;
var i: integer;
begin
i := Find(aName);
if i<0 then
SetVariantNull(result) else
RawUTF8ToVariant(List[i].Value,result);
end;
procedure TSynNameValue.AsDocVariant(out DocVariant: variant;
ExtendedJson,ValueAsString,AllowVarDouble: boolean);
var ndx: integer;
begin
if Count>0 then
with TDocVariantData(DocVariant) do begin
Init(JSON_OPTIONS_NAMEVALUE[ExtendedJson],dvObject);
VCount := self.Count;
SetLength(VName,VCount);
SetLength(VValue,VCount);
for ndx := 0 to VCount-1 do begin
VName[ndx] := List[ndx].Name;
if ValueAsString or not GetNumericVariantFromJSON(pointer(List[ndx].Value),
TVarData(VValue[ndx]),AllowVarDouble) then
RawUTF8ToVariant(List[ndx].Value,VValue[ndx]);
end;
end else
TVarData(DocVariant).VType := varNull;
end;
function TSynNameValue.AsDocVariant(ExtendedJson,ValueAsString: boolean): variant;
begin
AsDocVariant(result,ExtendedJson,ValueAsString);
end;
function TSynNameValue.MergeDocVariant(var DocVariant: variant;
ValueAsString: boolean; ChangedProps: PVariant; ExtendedJson,AllowVarDouble: Boolean): integer;
var DV: TDocVariantData absolute DocVariant;
i,ndx: integer;
v: variant;
intvalues: TRawUTF8Interning;
begin
if integer(DV.VType)<>DocVariantVType then
TDocVariant.New(DocVariant,JSON_OPTIONS_NAMEVALUE[ExtendedJson]);
if ChangedProps<>nil then
TDocVariant.New(ChangedProps^,DV.Options);
if dvoInternValues in DV.Options then
intvalues := DocVariantType.InternValues else
intvalues := nil;
result := 0; // returns number of changed values
for i := 0 to Count-1 do
if List[i].Name<>'' then begin
VarClear(v);
if ValueAsString or not GetNumericVariantFromJSON(pointer(List[i].Value),
TVarData(v),AllowVarDouble) then
RawUTF8ToVariant(List[i].Value,v);
ndx := DV.GetValueIndex(List[i].Name);
if ndx<0 then
ndx := DV.InternalAdd(List[i].Name) else
if SortDynArrayVariantComp(TVarData(v),TVarData(DV.Values[ndx]),false)=0 then
continue; // value not changed -> skip
if ChangedProps<>nil then
PDocVariantData(ChangedProps)^.AddValue(List[i].Name,v);
SetVariantByValue(v,DV.VValue[ndx]);
if intvalues<>nil then
intvalues.UniqueVariant(DV.VValue[ndx]);
inc(result);
end;
end;
{$endif NOVARIANTS}
{$ifdef MSWINDOWS}
function IsDebuggerPresent: BOOL; stdcall; external kernel32; // since XP
{$endif}
procedure SetCurrentThreadName(const Format: RawUTF8; const Args: array of const);
begin
SetThreadName(GetCurrentThreadId,Format,Args);
end;
procedure SetThreadName(ThreadID: TThreadID; const Format: RawUTF8;
const Args: array of const);
var name: RawUTF8;
begin
FormatUTF8(Format,Args,name);
name := StringReplaceAll(name,['TSQLRest','', 'TSQL','', 'TWebSocket','WS',
'TServiceFactory','SF', 'TSyn','', 'Thread','', 'Process','',
'Background','Bgd', 'Server','Svr', 'Client','Clt', 'WebSocket','WS',
'Timer','Tmr', 'Thread','Thd']);
SetThreadNameInternal(ThreadID,name);
end;
procedure SetThreadNameDefault(ThreadID: TThreadID; const Name: RawUTF8);
{$ifndef FPC}
{$ifndef NOSETTHREADNAME}
var s: RawByteString;
{$ifndef ISDELPHIXE2}
{$ifdef MSWINDOWS}
info: record
FType: LongWord; // must be 0x1000
FName: PAnsiChar; // pointer to name (in user address space)
FThreadID: LongWord; // thread ID (-1 indicates caller thread)
FFlags: LongWord; // reserved for future use, must be zero
end;
{$endif}
{$endif}
{$endif NOSETTHREADNAME}
{$endif FPC}
begin
{$ifdef FPC}
{$ifdef LINUX}
if ThreadID<>MainThreadID then // don't change the main process name
SetUnixThreadName(ThreadID, Name); // call pthread_setname_np()
{$endif}
{$else}
{$ifndef NOSETTHREADNAME}
{$ifdef MSWINDOWS}
if not IsDebuggerPresent then
exit;
{$endif MSWINDOWS}
s := CurrentAnsiConvert.UTF8ToAnsi(Name);
{$ifdef ISDELPHIXE2}
TThread.NameThreadForDebugging(s,ThreadID);
{$else}
{$ifdef MSWINDOWS}
info.FType := $1000;
info.FName := pointer(s);
info.FThreadID := ThreadID;
info.FFlags := 0;
try
RaiseException($406D1388,0,SizeOf(info) div SizeOf(LongWord),@info);
except {ignore} end;
{$endif MSWINDOWS}
{$endif ISDELPHIXE2}
{$endif NOSETTHREADNAME}
{$endif FPC}
end;
{ MultiEvent* functions }
function MultiEventFind(const EventList; const Event: TMethod): integer;
var Events: TMethodDynArray absolute EventList;
begin
if Event.Code<>nil then // callback assigned
for result := 0 to length(Events)-1 do
if (Events[result].Code=Event.Code) and
(Events[result].Data=Event.Data) then
exit;
result := -1;
end;
function MultiEventAdd(var EventList; const Event: TMethod): boolean;
var Events: TMethodDynArray absolute EventList;
n: integer;
begin
result := false;
n := MultiEventFind(EventList,Event);
if n>=0 then
exit; // already registered
result := true;
n := length(Events);
SetLength(Events,n+1);
Events[n] := Event;
end;
procedure MultiEventRemove(var EventList; const Event: TMethod);
begin
MultiEventRemove(EventList,MultiEventFind(EventList,Event));
end;
procedure MultiEventRemove(var EventList; Index: Integer);
var Events: TMethodDynArray absolute EventList;
max: integer;
begin
max := length(Events);
if cardinal(index)<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;
function EventEquals(const eventA,eventB): boolean;
var A: TMethod absolute eventA;
B: TMethod absolute eventB;
begin
result := (A.Code=B.Code) and (A.Data=B.Data);
end;
var
GarbageCollectorFreeAndNilList: TSynList;
procedure GarbageCollectorFree;
var i: integer;
po: PObject;
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
po := GarbageCollectorFreeAndNilList.List[i];
if (po<>nil) and (po^<>nil) then
FreeAndNil(po^);
except
on E: Exception do
; // just ignore exceptions in client code destructors
end;
FreeAndNil(GarbageCollectorFreeAndNilList);
end;
procedure GarbageCollectorFreeAndNil(var InstanceVariable; Instance: TObject);
begin
TObject(InstanceVariable) := Instance;
GarbageCollectorFreeAndNilList.Add(@InstanceVariable);
end;
var
GlobalCriticalSection: TRTLCriticalSection;
procedure GlobalLock;
begin
EnterCriticalSection(GlobalCriticalSection);
end;
procedure GlobalUnLock;
begin
LeaveCriticalSection(GlobalCriticalSection);
end;
{$ifdef CPUINTEL}
function IsXmmYmmOSEnabled: boolean; assembler; {$ifdef FPC} nostackframe; assembler; {$endif}
asm // see https://software.intel.com/en-us/blogs/2011/04/14/is-avx-enabled
xor ecx, ecx // specify control register XCR0 = XFEATURE_ENABLED_MASK
db $0f, $01, $d0 // XGETBV reads XCR0 into EDX:EAX
and eax, 6 // check OS has enabled both XMM (bit 1) and YMM (bit 2)
cmp al, 6
sete al
end;
procedure TestIntelCpuFeatures;
var regs: TRegisters;
c: cardinal;
begin
// retrieve CPUID raw flags
regs.edx := 0;
regs.ecx := 0;
GetCPUID(1,regs);
PIntegerArray(@CpuFeatures)^[0] := regs.edx;
PIntegerArray(@CpuFeatures)^[1] := regs.ecx;
GetCPUID(7,regs);
PIntegerArray(@CpuFeatures)^[2] := regs.ebx;
PIntegerArray(@CpuFeatures)^[3] := regs.ecx;
PIntegerArray(@CpuFeatures)^[4] := regs.edx;
{$ifdef DISABLE_SSE42} // paranoid execution on Darwin x64 (as reported by alf)
CpuFeatures := CpuFeatures-[cfSSE42,cfAESNI];
{$endif DISABLE_SSE42}
if not(cfOSXS in CpuFeatures) or not IsXmmYmmOSEnabled then
CpuFeatures := CpuFeatures-[cfAVX,cfAVX2,cfFMA];
{$ifndef ABSOLUTEPASCAL}
{$ifdef CPUX64}
{$ifdef WITH_ERMS}
if cfERMS in CpuFeatures then // actually slower than our AVX code -> disabled
include(CPUIDX64,cpuERMS);
{$endif WITH_ERMS}
if cfAVX in CpuFeatures then begin
include(CPUIDX64,cpuAVX);
if cfAVX2 in CpuFeatures then
include(CPUIDX64,cpuAVX2);
end;
{$endif CPUX64}
{$endif ABSOLUTEPASCAL}
// validate accuracy of most used HW opcodes
if cfRAND in CpuFeatures then
try
c := RdRand32;
if RdRand32=c then // most probably a RDRAND bug, e.g. on AMD Rizen 3000
exclude(CpuFeatures,cfRAND);
except // may trigger an illegal instruction exception on some Ivy Bridge
exclude(CpuFeatures,cfRAND);
end;
if cfSSE42 in CpuFeatures then
try
if crc32cBy4SSE42(0,1)<>3712330424 then
raise ESynException.Create('Invalid crc32cBy4SSE42');
except // disable now on illegal instruction or incorrect result
exclude(CpuFeatures,cfSSE42);
end;
end;
{$endif CPUINTEL}
procedure InitFunctionsRedirection;
begin
{$ifdef CPUINTEL}
TestIntelCpuFeatures;
{$endif CPUINTEL}
{$ifndef MSWINDOWS} // now for RedirectCode (RetrieveSystemInfo is too late)
SystemInfo.dwPageSize := getpagesize; // use libc for this value
if SystemInfo.dwPageSize=0 then // should not be 0
SystemInfo.dwPageSize := 4096;
{$endif MSWINDOWS}
{$ifdef PUREPASCAL}
{$ifndef HASINLINE}
PosEx := @PosExPas;
{$endif HASINLINE}
PosExString := @PosExStringPas; // fast pure pascal process
{$else not PUREPASCAL}
{$ifdef UNICODE}
PosExString := @PosExStringPas; // fast PWideChar process
{$else}
PosExString := @PosEx; // use optimized PAnsiChar i386 asm
{$endif UNICODE}
{$endif PUREPASCAL}
crc32c := @crc32cfast; // now to circumvent Internal Error C11715 for Delphi 5
crc32cBy4 := @crc32cBy4fast;
{$ifndef CPUX64}
MoveFast := @System.Move;
{$endif CPUX64}
{$ifdef FPC}
{$ifdef CPUX64}
{$ifndef ABSOLUTEPASCAL}
if @System.FillChar<>@FillCharFast then begin
// force to use our optimized x86_64 asm versions
RedirectCode(@System.FillChar,@FillcharFast);
RedirectCode(@System.Move,@MoveFast);
{$ifdef DOPATCHTRTL}
PatchCode(@fpc_ansistr_incr_ref,@_ansistr_incr_ref,$17); // fpclen=$2f
PatchJmp(@fpc_ansistr_decr_ref,@_ansistr_decr_ref,$27); // fpclen=$3f
PatchJmp(@fpc_ansistr_assign,@_ansistr_assign,$3f); // fpclen=$3f
PatchCode(@fpc_ansistr_compare,@_ansistr_compare,$77); // fpclen=$12f
PatchCode(@fpc_ansistr_compare_equal,@_ansistr_compare_equal,$57); // =$cf
PatchCode(@fpc_unicodestr_incr_ref,@_ansistr_incr_ref,$17); // fpclen=$2f
PatchJmp(@fpc_unicodestr_decr_ref,@_ansistr_decr_ref,$27); // fpclen=$3f
PatchJmp(@fpc_unicodestr_assign,@_ansistr_assign,$3f); // fpclen=$3f
PatchCode(@fpc_dynarray_incr_ref,@_dynarray_incr_ref,$17); // fpclen=$2f
PatchJmp(@fpc_dynarray_clear,@_dynarray_decr_ref,$2f,PtrUInt(@_dynarray_decr_ref_free));
RedirectCode(@fpc_dynarray_decr_ref,@fpc_dynarray_clear);
{$ifdef FPC_HAS_CPSTRING}
{$ifdef LINUX}
if (DefaultSystemCodePage=CP_UTF8) or (DefaultSystemCodePage=0) then begin
RedirectRtl(@_fpc_ansistr_concat,@_ansistr_concat_utf8);
RedirectRtl(@_fpc_ansistr_concat_multi,@_ansistr_concat_multi_utf8);
end;
{$endif LINUX}
{$ifdef FPC_X64MM}
RedirectCode(@fpc_ansistr_setlength,@_ansistr_setlength);
{$endif FPC_X64MM}
{$endif FPC_HAS_CPSTRING}
{$ifdef FPC_X64MM}
RedirectCode(@fpc_getmem,@_Getmem);
RedirectCode(@fpc_freemem,@_Freemem);
{$endif FPC_X64MM}
{$endif DOPATCHTRTL}
end;
{$endif ABSOLUTEPASCAL}
{$else}
FillCharFast := @System.FillChar; // fallback to FPC cross-platform RTL
{$endif CPUX64}
{$else Dephi: }
{$ifdef CPUARM}
FillCharFast := @System.FillChar;
{$else}
{$ifndef CPUX64}
Pointer(@FillCharFast) := SystemFillCharAddress;
{$endif CPUX64}
{$ifdef DELPHI5OROLDER}
StrLen := @StrLenX86;
MoveFast := @MoveX87;
FillcharFast := @FillCharX87;
{$else DELPHI5OROLDER}
{$ifdef CPU64} // x86_64 redirection
{$ifdef HASAESNI}
{$ifdef FORCE_STRSSE42}
if cfSSE42 in CpuFeatures then begin
StrLen := @StrLenSSE42;
StrComp := @StrCompSSE42;
end else
{$endif FORCE_STRSSE42}
{$endif HASAESNI}
StrLen := @StrLenSSE2;
{$else} // i386 redirection
{$ifdef CPUINTEL}
if cfSSE2 in CpuFeatures then begin
{$ifdef FORCE_STRSSE42}
if cfSSE42 in CpuFeatures then
StrLen := @StrLenSSE42 else
{$endif FORCE_STRSSE42}
StrLen := @StrLenSSE2;
FillcharFast := @FillCharSSE2;
end else begin
StrLen := @StrLenX86;
FillcharFast := @FillCharX87;
end;
{$ifdef WITH_ERMS} // disabled by default (much slower for small blocks)
if cfERMS in CpuFeatures then begin
MoveFast := @MoveERMSB;
FillcharFast := @FillCharERMSB;
end else {$endif}
MoveFast := @MoveX87; // SSE2 is not faster than X87 version on 32-bit CPU
{$endif CPUINTEL}
{$endif CPU64}
{$endif DELPHI5OROLDER}
{$ifndef USEPACKAGES}
// do redirection from RTL to our fastest version
{$ifdef DOPATCHTRTL}
if DebugHook=0 then begin // patch only outside debugging
RedirectCode(SystemFillCharAddress,@FillcharFast);
RedirectCode(@System.Move,@MoveFast);
{$ifdef CPUX86}
RedirectCode(SystemRecordCopyAddress,@RecordCopy);
RedirectCode(SystemFinalizeRecordAddress,@RecordClear);
RedirectCode(SystemInitializeRecordAddress,@_InitializeRecord);
{$ifndef UNICODE} // buggy Delphi 2009+ RTL expects a TMonitor.Destroy call
RedirectCode(@TObject.CleanupInstance,@TObjectCleanupInstance);
{$endif UNICODE}
{$endif}
end;
{$endif DOPATCHTRTL}
{$endif USEPACKAGES}
{$endif CPUARM}
{$endif FPC}
UpperCopy255Buf := @UpperCopy255BufPas;
DefaultHasher := @xxHash32; // faster than crc32cfast for small content
{$ifndef ABSOLUTEPASCAL}
{$ifdef CPUINTEL}
{$ifdef FPC} // StrLen was set above for Delphi
{$ifdef CPUX86}
if cfSSE2 in CpuFeatures then
{$endif CPUX86}
StrLen := @StrLenSSE2;
{$endif FPC}
if cfSSE42 in CpuFeatures then begin
crc32c := @crc32csse42; // seems safe on all targets
crc32cby4 := @crc32cby4sse42;
crcblock := @crcblockSSE42;
crcblocks := @crcblocksSSE42;
{$ifdef FORCE_STRSSE42} // disabled by default: may trigger random GPF
strspn := @strspnSSE42;
strcspn := @strcspnSSE42;
{$ifdef CPU64}
{$ifdef FPC} // done in InitRedirectCode for Delphi
{$ifdef HASAESNI}
StrLen := @StrLenSSE42;
StrComp := @StrCompSSE42;
{$endif HASAESNI}
{$endif FPC}
{$endif CPU64}
{$ifndef PUREPASCAL}
{$ifndef DELPHI5OROLDER}
UpperCopy255Buf := @UpperCopy255BufSSE42;
{$endif DELPHI5OROLDER}
{$endif PUREPASCAL}
{$ifndef PUREPASCAL}
StrComp := @StrCompSSE42;
DYNARRAY_SORTFIRSTFIELD[false,djRawUTF8] := @SortDynArrayAnsiStringSSE42;
DYNARRAY_SORTFIRSTFIELD[false,djWinAnsi] := @SortDynArrayAnsiStringSSE42;
{$ifndef UNICODE}
DYNARRAY_SORTFIRSTFIELD[false,djString] := @SortDynArrayAnsiStringSSE42;
{$endif}
DYNARRAY_SORTFIRSTFIELDHASHONLY[true] := @SortDynArrayAnsiStringSSE42;
{$endif PUREPASCAL}
{$endif FORCE_STRSSE42}
DefaultHasher := crc32c;
end;
if cfPOPCNT in CpuFeatures then
GetBitsCountPtrInt := @GetBitsCountSSE42;
{$endif CPUINTEL}
{$endif ABSOLUTEPASCAL}
InterningHasher := DefaultHasher;
end;
procedure InitSynCommonsConversionTables;
var i,n: integer;
v: byte;
c: AnsiChar;
crc: cardinal;
tmp: array[0..15] of AnsiChar;
P: PAnsiChar;
{$ifdef OWNNORMTOUPPER}
d: integer;
const n2u: array[138..255] of byte =
(83,139,140,141,90,143,144,145,146,147,148,149,150,151,152,153,83,155,140,
157,90,89,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,
176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,65,65,65,
65,65,65,198,67,69,69,69,69,73,73,73,73,68,78,79,79,79,79,79,215,79,85,85,
85,85,89,222,223,65,65,65,65,65,65,198,67,69,69,69,69,73,73,73,73,68,78,79,
79,79,79,79,247,79,85,85,85,85,89,222,89);
{$endif OWNNORMTOUPPER}
const HexChars: array[0..15] of AnsiChar = '0123456789ABCDEF';
HexCharsLower: array[0..15] of AnsiChar = '0123456789abcdef';
begin
JSON_CONTENT_TYPE_VAR := JSON_CONTENT_TYPE;
JSON_CONTENT_TYPE_HEADER_VAR := JSON_CONTENT_TYPE_HEADER;
NULL_STR_VAR := 'null';
BOOL_UTF8[false] := 'false';
BOOL_UTF8[true] := 'true';
{$ifdef FPC}
{$ifdef ISFPC27}
{$ifndef MSWINDOWS}
GetACP := GetSystemCodePage;
{$endif MSWINDOWS}
SetMultiByteConversionCodePage(CP_UTF8);
SetMultiByteRTLFileSystemCodePage(CP_UTF8);
{$endif ISFPC27}
{$endif FPC}
{$ifdef KYLIX3}
// if default locale is set to *.UTF-8, which is the case in most modern
// linux default configuration, unicode decode will fail in SysUtils.CheckLocale
setlocale(LC_CTYPE,'en_US'); // force locale for a UTF-8 server
{$endif}
{$ifndef EXTENDEDTOSHORT_USESTR}
{$ifdef ISDELPHIXE}
SettingsUS := TFormatSettings.Create($0409);
{$else}
GetLocaleFormatSettings($0409,SettingsUS);
{$endif}
SettingsUS.DecimalSeparator := '.'; // value may have been overriden :(
{$endif}
for i := 0 to 255 do
NormToNormByte[i] := i;
NormToUpperAnsi7Byte := NormToNormByte;
for i := ord('a') to ord('z') do
dec(NormToUpperAnsi7Byte[i],32);
{$ifdef OWNNORMTOUPPER}
MoveFast(NormToUpperAnsi7,NormToUpper,138);
MoveFast(n2u,NormToUpperByte[138],SizeOf(n2u));
for i := 0 to 255 do begin
d := NormToUpperByte[i];
if d in [ord('A')..ord('Z')] then
inc(d,32);
NormToLowerByte[i] := d;
end;
{$endif OWNNORMTOUPPER}
FillcharFast(ConvertHexToBin[0],SizeOf(ConvertHexToBin),255); // all to 255
v := 0;
for i := ord('0') to ord('9') do begin
ConvertHexToBin[i] := v;
inc(v);
end;
for i := ord('A') to ord('F') do begin
ConvertHexToBin[i] := v;
ConvertHexToBin[i+(ord('a')-ord('A'))] := v;
inc(v);
end;
for i := 0 to 255 do begin
TwoDigitsHex[i][1] := HexChars[i shr 4];
TwoDigitsHex[i][2] := HexChars[i and $f];
end;
for i := 0 to 255 do begin
TwoDigitsHexLower[i][1] := HexCharsLower[i shr 4];
TwoDigitsHexLower[i][2] := HexCharsLower[i and $f];
end;
MoveFast(TwoDigitLookup[0], TwoDigitByteLookupW[0], SizeOf(TwoDigitLookup));
for i := 0 to 199 do
dec(PByteArray(@TwoDigitByteLookupW)[i],ord('0')); // '0'..'9' -> 0..9
FillcharFast(ConvertBase64ToBin,256,255); // invalid value set to -1
for i := 0 to high(b64enc) do
ConvertBase64ToBin[b64enc[i]] := i;
ConvertBase64ToBin['='] := -2; // special value for '='
for i := 0 to high(b64urienc) do
ConvertBase64uriToBin[b64urienc[i]] := i;
for i := high(Baudot2Char) downto 0 do
if Baudot2Char[i]<#128 then
Char2Baudot[Baudot2Char[i]] := i;
for i := ord('a') to ord('z') do
Char2Baudot[AnsiChar(i-32)] := Char2Baudot[AnsiChar(i)]; // A-Z -> a-z
JSON_ESCAPE[0] := 1; // 1 for #0 end of input
for i := 1 to 31 do // 0 indicates no JSON escape needed
JSON_ESCAPE[i] := 2; // 2 should be escaped as \u00xx
JSON_ESCAPE[8] := ord('b'); // others contain the escaped character
JSON_ESCAPE[9] := ord('t');
JSON_ESCAPE[10] := ord('n');
JSON_ESCAPE[12] := ord('f');
JSON_ESCAPE[13] := ord('r');
JSON_ESCAPE[ord('\')] := ord('\');
JSON_ESCAPE[ord('"')] := ord('"');
include(JSON_CHARS[#0], jcEndOfJSONFieldOr0);
for c := low(c) to high(c) do begin
if not (c in [#0,#10,#13]) then
include(TEXT_CHARS[c], tcNot01013);
if c in [#10,#13] then
include(TEXT_CHARS[c], tc1013);
if c in ['0'..'9','a'..'z','A'..'Z'] then
include(TEXT_CHARS[c], tcWord);
if c in ['_','a'..'z','A'..'Z'] then
include(TEXT_CHARS[c], tcIdentifierFirstChar);
if c in ['_','0'..'9','a'..'z','A'..'Z'] then
include(TEXT_CHARS[c], tcIdentifier);
if c in ['_','-','.','0'..'9','a'..'z','A'..'Z'] then
// '~' is part of the RFC 3986 but should be escaped in practice
// see https://blog.synopse.info/?post/2020/08/11/The-RFC%2C-The-URI%2C-and-The-Tilde
include(TEXT_CHARS[c], tcURIUnreserved);
if c in [#1..#9,#11,#12,#14..' '] then
include(TEXT_CHARS[c], tcCtrlNotLF);
if c in [#1..' ',';'] then
include(TEXT_CHARS[c], tcCtrlNot0Comma);
if c in [',',']','}',':'] then begin
include(JSON_CHARS[c], jcEndOfJSONField);
include(JSON_CHARS[c], jcEndOfJSONFieldOr0);
end;
if c in [#0,#9,#10,#13,' ',',','}',']'] then
include(JSON_CHARS[c], jcEndOfJSONValueField);
if c in ['-','0'..'9'] then
include(JSON_CHARS[c], jcDigitFirstChar);
if c in ['-','+','0'..'9'] then
include(JSON_CHARS[c], jcDigitChar);
if c in ['-','+','0'..'9','.','E','e'] then
include(JSON_CHARS[c], jcDigitFloatChar);
if c in ['_','0'..'9','a'..'z','A'..'Z','$'] then
include(JSON_CHARS[c], jcJsonIdentifierFirstChar);
if c in ['_','0'..'9','a'..'z','A'..'Z','.','[',']'] then
include(JSON_CHARS[c], jcJsonIdentifier);
end;
TSynAnsiConvert.Engine(0); // define CurrentAnsi/WinAnsi/UTF8AnsiConvert
for i := 0 to 255 do begin
crc := i;
for n := 1 to 8 do
if (crc and 1)<>0 then // polynom is not the same as with zlib's crc32()
crc := (crc shr 1) xor $82f63b78 else
crc := crc shr 1;
crc32ctab[0,i] := crc; // for crc32cfast() and SymmetricEncrypt/FillRandom
end;
for i := 0 to 255 do begin
crc := crc32ctab[0,i];
for n := 1 to high(crc32ctab) do begin
crc := (crc shr 8) xor crc32ctab[0,ToByte(crc)];
crc32ctab[n,i] := crc;
end;
end;
for i := 0 to high(SmallUInt32UTF8) do begin
P := StrUInt32(@tmp[15],i);
FastSetString(SmallUInt32UTF8[i],P,@tmp[15]-P);
end;
KINDTYPE_INFO[djRawUTF8] := TypeInfo(RawUTF8); // for TDynArray.LoadKnownType
KINDTYPE_INFO[djWinAnsi] := TypeInfo(WinAnsiString);
KINDTYPE_INFO[djString] := TypeInfo(String);
KINDTYPE_INFO[djRawByteString] := TypeInfo(RawByteString);
KINDTYPE_INFO[djWideString] := TypeInfo(WideString);
KINDTYPE_INFO[djSynUnicode] := TypeInfo(SynUnicode);
{$ifndef NOVARIANTS}KINDTYPE_INFO[djVariant] := TypeInfo(variant);{$endif}
end;
initialization
// initialization of internal dynamic functions and tables
InitFunctionsRedirection;
InitializeCriticalSection(GlobalCriticalSection);
GarbageCollectorFreeAndNilList := TSynList.Create;
GarbageCollectorFreeAndNil(GarbageCollector,TSynObjectList.Create);
InitSynCommonsConversionTables;
RetrieveSystemInfo;
SetExecutableVersion(0,0,0,0);
AlgoSynLZ := TAlgoSynLZ.Create;
GarbageCollectorFreeAndNil(GlobalCustomJSONSerializerFromTextSimpleType,
TSynDictionary.Create(TypeInfo(TRawUTF8DynArray),
TypeInfo(TJSONSerializerFromTextSimpleDynArray),true));
TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType(
{$ifdef ISDELPHI2010}TypeInfo(TGUID){$else}nil{$endif},'TGUID');
TTextWriter.RegisterCustomJSONSerializerFromText([
TypeInfo(TFindFilesDynArray),
'Name:string Attr:Integer Size:Int64 Timestamp:TDateTime']);
// some paranoid cross-platform/cross-compiler assertions
{$ifndef NOVARIANTS}
Assert(SizeOf(TVarData)={$ifdef CPU64}24{$else}16{$endif}); // for ExchgVariant
Assert(SizeOf(TDocVariantData)=SizeOf(TVarData));
DocVariantType := TDocVariant(SynRegisterCustomVariantType(TDocVariant));
DocVariantVType := DocVariantType.VarType;
{$endif NOVARIANTS}
{$ifndef FPC}{$warnings OFF}{$endif}
Assert((MAX_SQLFIELDS>=64)and(MAX_SQLFIELDS<=256));
{$ifndef FPC}{$warnings ON}{$endif}
Assert(SizeOf(THash128Rec)=SizeOf(THash128));
Assert(SizeOf(THash256Rec)=SizeOf(THash256));
Assert(SizeOf(TBlock128)=SizeOf(THash128));
assert(SizeOf(TSynSystemTime)=SizeOf(TSystemTime));
assert(SizeOf(TSynSystemTime)=SizeOf(THash128));
Assert(SizeOf(TOperatingSystemVersion)=SizeOf(integer));
Assert(SizeOf(TSynLocker)>=128,'cpucacheline');
Assert(SizeOf(TJsonChar)=1);
Assert(SizeOf(TTextChar)=1);
{$ifdef MSWINDOWS}
{$ifndef CPU64}
Assert(SizeOf(TFileTime)=SizeOf(Int64)); // see e.g. FileTimeToInt64
{$endif CPU64}
{$endif MSWINDOWS}
finalization
{$ifndef NOVARIANTS}
DocVariantType.Free;
{$endif NOVARIANTS}
GarbageCollectorFree;
DeleteCriticalSection(GlobalCriticalSection);
//writeln('TDynArrayHashedCollisionCount=',TDynArrayHashedCollisionCount); readln;
end.
Reference in New Issue View Git Blame Copy Permalink